From 7e6628febc482b4ad451f49ad416722375d1b170 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 26 Jun 2020 15:29:18 +0530 Subject: Update for modular ping pong --- haddock-api/src/Haddock/Interface/Create.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7b9674a6..1f223282 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -34,7 +34,6 @@ import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Control.Applicative import Control.Monad import Data.Traversable @@ -49,7 +48,6 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State -import GHC.Data.Bag import GHC.Types.Name.Reader import GHC.Tc.Types import GHC.Data.FastString ( unpackFS, bytesFS ) @@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O import GHC.HsToCore.Docs hiding (mkMaps) -import GHC.Core.Multiplicity - -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource = -- -- With our mapping we know that we can display exported modules M1 and M2. -- -unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls = M.map (map (unLoc . ideclName)) $ M.filter (all isInteresting) impModMap @@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons = typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs data_ty con -- cgit v1.2.3 From cdae236f0ab7015f3a466b2c9b2449ba038b45f6 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Fri, 26 Jun 2020 16:48:44 +0200 Subject: Fix after Outputable refactoring --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 +++++--- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 +++- haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 4 +++- haddock-api/src/Haddock/Interface/Create.hs | 8 +++++--- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- 8 files changed, 20 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index d280ed23..8d56a1ed 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -26,7 +26,9 @@ import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC +import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic import Data.Char import Data.List @@ -106,14 +108,14 @@ outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr f [] = [] out :: Outputable a => DynFlags -> a -> String -out dflags = outWith $ showSDocUnqual dflags +out dflags = outWith $ showSDoc dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x commaSeparate :: Outputable a => DynFlags -> [a] -> String -commaSeparate dflags = showSDocUnqual dflags . interpp'SP +commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -173,7 +175,7 @@ ppClass dflags decl subdocs = ppTyFams | null $ tcdATs decl = "" - | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat [ map pprTyFam (tcdATs decl) , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 5fd040a8..114eafa9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -17,7 +17,9 @@ import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) , mkPStatePure, lexer, mkParserFlags', getErrorMessages) import GHC.Data.Bag ( bagToList ) -import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) ) +import GHC.Utils.Outputable ( text, ($$) ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index ce5ff11c..5daa5522 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -21,7 +21,7 @@ import GHC import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) import GHC.Iface.Type import GHC.Types.Name ( getOccFS, getOccString ) -import GHC.Utils.Outputable( showSDoc ) +import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((), (<.>)) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c439be8f..32ca4f6a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -31,7 +31,7 @@ import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS ) -import GHC.Utils.Outputable ( panic) +import GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d8f7206f..35cb3d92 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -47,7 +47,7 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey import GHC.Types.Unique ( getUnique ) import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength , filterByList, filterOut ) -import GHC.Utils.Outputable ( assertPanic ) +import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 6fae5f58..b4964d9f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -27,7 +27,9 @@ import Data.Char ( isSpace ) import Haddock.Types( DocName, DocNameI ) import GHC.Utils.FV as FV -import GHC.Utils.Outputable ( Outputable, panic, showPpr ) +import GHC.Utils.Outputable ( Outputable ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC.Driver.Types diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 1f223282..ffaec7f1 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -44,6 +44,7 @@ import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Core.ConLike (ConLike(..)) import GHC import GHC.Driver.Types +import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -53,6 +54,7 @@ import GHC.Tc.Types import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O +import GHC.Utils.Panic import GHC.HsToCore.Docs hiding (mkMaps) @@ -722,7 +724,7 @@ hiDecl dflags t = do warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> O.text "-- Please report this on Haddock issue tracker!" - bugWarn = O.showSDoc dflags . warnLine + bugWarn = showSDoc dflags . warnLine -- | This function is called for top-level bindings without type signatures. -- It gets the type signature from GHC and that means it's not going to @@ -884,7 +886,7 @@ extractDecl declMap name decl ([], []) | Just (famInstDecl:_) <- M.lookup name declMap -> extractDecl declMap name famInstDecl - _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" + _ -> pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) @@ -927,7 +929,7 @@ extractDecl declMap name decl in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) _ -> error "internal: extractDecl (ClsInstD)" - _ -> O.pprPanic "extractDecl" $ + _ -> pprPanic "extractDecl" $ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" O.$$ O.nest 4 (O.ppr decl) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2b03ecfa..2c06438f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -32,7 +32,7 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import GHC.Types.Name -import GHC.Utils.Outputable ( showPpr, showSDoc ) +import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet import GHC.Rename.Env (dataTcOccs) -- cgit v1.2.3 From a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 6 Oct 2020 18:38:35 +0100 Subject: Match GHC, adding IsUnicodeSyntax field to HsFunTy and HsScaled --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 ++- haddock-api/src/Haddock/Convert.hs | 7 ++++--- haddock-api/src/Haddock/GhcUtils.hs | 7 ++++--- haddock-api/src/Haddock/Interface/Create.hs | 5 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 6 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 5 +++-- 6 files changed, 19 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 90bd6b66..ecc4bf97 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -29,6 +29,7 @@ import GHC import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char import Data.List @@ -245,7 +246,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 35cb3d92..650f8a1d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -51,6 +51,7 @@ import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize @@ -767,9 +768,9 @@ noKindTyVars _ _ = emptyVarSet synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow - Many -> HsUnrestrictedArrow - ty -> HsExplicitMult (synifyType WithinType vs ty) + One -> HsLinearArrow NormalSyntax + Many -> HsUnrestrictedArrow NormalSyntax + ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index b4964d9f..a03587b4 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -44,6 +44,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar ) import GHC.Builtin.Types( liftedRepDataConTyCon ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer as S @@ -156,13 +157,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty --- tau_ty :: LHsType DocNameI +-- tau_ty :: LHsType DocNameI tau_ty = case args of RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -218,7 +219,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ffaec7f1..46f0cfe8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -56,6 +56,7 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -957,7 +958,7 @@ extractPatternSyn nm t tvs cons = in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -974,7 +975,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 39a1ae17..67439383 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -223,9 +223,9 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) -renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow -renameArrow HsLinearArrow = return HsLinearArrow -renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) +renameArrow (HsLinearArrow u) = return (HsLinearArrow u) +renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 28806f04..ad5063b3 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -17,6 +17,7 @@ import GHC import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -136,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -290,7 +291,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameHsArrow mult = pure mult -- cgit v1.2.3 From 904a3c276643d15da24303493b62e95dfb0b7726 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 26 Oct 2020 19:31:54 +0100 Subject: GHC.Driver.Types refactoring (#1242) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 5 +++-- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 6 ++++-- haddock-api/src/Haddock/GhcUtils.hs | 1 - haddock-api/src/Haddock/Interface.hs | 3 ++- haddock-api/src/Haddock/Interface/Create.hs | 8 ++++++-- haddock-api/src/Haddock/Interface/Json.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Types.hs | 3 ++- 9 files changed, 20 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ecc4bf97..c9aad6ed 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -17,8 +17,9 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) - , PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), + PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1b3ed35c..1de62a2e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -9,7 +9,7 @@ import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import GHC.Types.Basic ( IntegralLit(..) ) +import GHC.Types.SourceText import GHC.Driver.Session import GHC.Utils.Error ( pprLocErrMsg ) import GHC.Data.FastString ( mkFastString ) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 650f8a1d..7eb9c683 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,8 +22,9 @@ module Haddock.Convert ( #include "HsVersions.h" import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) - , PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike @@ -31,6 +32,7 @@ import Data.Either (lefts, rights) import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs +import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a03587b4..8d0b382b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -32,7 +32,6 @@ import GHC.Utils.Panic ( panic ) import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module -import GHC.Driver.Types import GHC import GHC.Core.Class import GHC.Driver.Session diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index a702d3d6..583cacf8 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -51,11 +51,12 @@ import Distribution.Verbosity import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) +import GHC.Unit.Module.ModSummary import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Data.FastString (unpackFS) import GHC.Tc.Types (tcg_rdr_env) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 46f0cfe8..59809e89 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -40,10 +40,12 @@ import Data.Traversable import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.SourceFile import GHC.Core.ConLike (ConLike(..)) import GHC -import GHC.Driver.Types import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set @@ -52,11 +54,13 @@ import GHC.Unit.State import GHC.Types.Name.Reader import GHC.Tc.Types import GHC.Data.FastString ( unpackFS, bytesFS ) -import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) +import GHC.Types.Basic ( PromotionFlag(..) ) +import GHC.Types.SourceText import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.HsToCore.Docs hiding (mkMaps) import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.Module.Warnings -- | Use a 'TypecheckedModule' to produce an 'Interface'. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 043a1530..df585f29 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -5,7 +5,7 @@ module Haddock.Interface.Json ( , renderJson ) where -import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index fffef2fa..72fcb79b 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -38,7 +38,7 @@ import GHC.Data.FastMutInt import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 89fd6658..6aad5dd1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -36,7 +36,8 @@ import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) import Documentation.Haddock.Types -import GHC.Types.Basic (Fixity(..), PromotionFlag(..)) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Fixity (Fixity(..)) import GHC import GHC.Driver.Session (Language) -- cgit v1.2.3 From 3cce1bdee8c61bb6daa089059e12435178f50770 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sat, 24 Oct 2020 10:38:55 -0400 Subject: Adapt to HsConDecl{H98,GADT}Details split Needed for GHC#18844. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 30 ++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 30 ++++++------ haddock-api/src/Haddock/Convert.hs | 64 +++++++++++++++----------- haddock-api/src/Haddock/GhcUtils.hs | 17 +++---- haddock-api/src/Haddock/Interface/Create.hs | 18 +++++--- haddock-api/src/Haddock/Interface/Rename.hs | 26 +++++++---- haddock-api/src/Haddock/Utils.hs | 28 +++++++---- 8 files changed, 124 insertions(+), 93 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index c9aad6ed..8939664d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -236,9 +236,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] -ppCtor dflags dat subdocs con@ConDeclH98 {} +ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index a90d9a6e..d0528322 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -796,20 +796,22 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = , ppLType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> doRecordFields fields - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) - - _ -> empty + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> doConstrArgsWithDocs [] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + _ -> empty + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> doRecordFields fields + -- H98 prefix data constructors + PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + _ -> empty doRecordFields fields = vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 20e099ee..d80f8e95 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -937,20 +937,22 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , fixity ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> [ doRecordFields fields ] - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - - _ -> [] + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b7faf6cd..c0347e56 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -387,34 +387,44 @@ synifyDataCon use_gadt_syntax dc = con_decl_field fl synTy = noLoc $ ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel 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) - (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) - (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) - _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) + mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> Left "synifyDataCon: contradiction!" + (True,False) -> return $ RecCon (noLoc field_tys) + (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) + (False,True) -> case linear_tys of + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) + _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn + mk_gadt_arg_tys + | use_named_field_syntax = RecConGADT (noLoc field_tys) + | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) + -- finally we get synifyDataCon's result! - in hs_arg_tys >>= - \hat -> - if use_gadt_syntax - then return $ noLoc $ - ConDeclGADT { con_g_ext = [] - , con_names = [name] - , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyTyVarBndr user_tvbndrs - , con_mb_cxt = ctx - , con_args = hat - , con_res_ty = synifyType WithinType [] res_ty - , con_doc = Nothing } - else return $ noLoc $ - ConDeclH98 { con_ext = noExtField - , con_name = name - , con_forall = noLoc False - , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs - , con_mb_cxt = ctx - , con_args = hat - , con_doc = Nothing } + in if use_gadt_syntax + then do + let hat = mk_gadt_arg_tys + return $ noLoc $ ConDeclGADT + { con_g_ext = [] + , con_names = [name] + , con_forall = noLoc $ not $ null user_tvbndrs + , con_qvars = map synifyTyVarBndr user_tvbndrs + , con_mb_cxt = ctx + , con_g_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } + else do + hat <- mk_h98_arg_tys + return $ noLoc $ ConDeclH98 + { con_ext = noExtField + , con_name = name + , con_forall = noLoc False + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 8d0b382b..d6d12e4e 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -134,9 +134,6 @@ mkHsForAllInvisTeleI :: mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI -getConArgsI d = con_args d - getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So @@ -144,7 +141,7 @@ getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- 'undefined's getGADTConType (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField , hst_tele = mkHsForAllInvisTeleI qtvs @@ -158,9 +155,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) + RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) @@ -199,7 +195,7 @@ getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn -- 'undefined's getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField , hst_tele = mkHsForAllInvisTele qtvs @@ -213,9 +209,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) + RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59809e89..ecaf1a5d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -926,7 +926,7 @@ extractDecl declMap name decl let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) + , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , extFieldOcc n == name @@ -949,10 +949,14 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConArgs con of - PrefixCon args' -> (map hsScaledThing args') - RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + case con of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon args' -> map hsScaledThing args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT args' -> map hsScaledThing args' + RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of @@ -977,8 +981,8 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = - case getConArgs con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> + case getRecConArgs_maybe con of + Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 67439383..e7d19dfe 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -479,7 +479,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameH98Details details mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' @@ -487,18 +487,18 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_args = details', con_doc = mbldoc' }) renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars - , con_mb_cxt = lcontext, con_args = details + , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty, con_forall = forall , con_doc = mbldoc } = do lnames' <- mapM renameL lnames ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc return (ConDeclGADT { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' - , con_mb_cxt = lcontext', con_args = details' + , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' , con_forall = forall}) -- Remove when #18311 is fixed @@ -506,18 +506,24 @@ renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) -renameDetails (RecCon (L l fields)) = do +renameH98Details :: HsConDeclH98Details GhcRn + -> RnM (HsConDeclH98Details DocNameI) +renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) - -- This causes an assertion failure ---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps -renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps -renameDetails (InfixCon a b) = do +renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps +renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn + -> RnM (HsConDeclGADTDetails DocNameI) +renameGADTDetails (RecConGADT (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecConGADT (L l fields')) +renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps + renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 33fbd000..1177fb18 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -187,21 +187,33 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + case d of + ConDeclH98 { con_args = args } -> restrict_h98_args args + ConDeclGADT { con_g_args = args } -> restrict_gadt_args args + where + restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn) + restrict_h98_args (PrefixCon _) = Just d + restrict_h98_args (RecCon (L _ fields)) + | all field_avail fields = Just d + | otherwise = Just (d { con_args = PrefixCon (field_types 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 + + restrict_h98_args (InfixCon _ _) = Just d + + restrict_gadt_args :: HsConDeclGADTDetails GhcRn -> Maybe (ConDecl GhcRn) + restrict_gadt_args (PrefixConGADT _) = Just d + restrict_gadt_args (RecConGADT (L _ fields)) + | all field_avail fields = Just d + | otherwise = Just (d { con_g_args = PrefixConGADT (field_types fields) }) + -- see the comments for the RecCon case of `restrict_h98_args` above + field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ] + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] keep _ = Nothing -- cgit v1.2.3 From ad9cbad7312a64e6757c32bd9488c55ba4f2fec9 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 23 Sep 2020 20:37:34 -0400 Subject: Adapt to HsOuterTyVarBndrs These changes accompany ghc/ghc!4107, which aims to be a fix for #16762. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 61 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 66 ++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 94 +++++--- haddock-api/src/Haddock/Convert.hs | 44 ++-- haddock-api/src/Haddock/GhcUtils.hs | 76 ++++--- haddock-api/src/Haddock/Interface/Create.hs | 17 +- haddock-api/src/Haddock/Interface/Rename.hs | 70 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 69 ++++-- haddock-api/src/Haddock/Syb.hs | 17 +- haddock-api/src/Haddock/Types.hs | 11 +- haddock-api/src/Haddock/Utils.hs | 34 ++- hypsrc-test/ref/src/Classes.html | 276 ++++++++++++------------ 12 files changed, 488 insertions(+), 347 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8939664d..44841bc5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -71,27 +71,31 @@ ppModule dflags iface = --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p) -dropHsDocTy = f +dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy = drop_sig_ty where - g (L src x) = L src (f x) - f (HsForAllTy x a e) = HsForAllTy x a (g e) - f (HsQualTy x a e) = HsQualTy x a (g e) - f (HsBangTy x a b) = HsBangTy x a (g b) - f (HsAppTy x a b) = HsAppTy x (g a) (g b) - f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) - f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) - f (HsListTy x a) = HsListTy x (g a) - f (HsTupleTy x a b) = HsTupleTy x a (map g b) - f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) - f (HsParTy x a) = HsParTy x (g a) - f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a - f x = x - -outHsType :: (OutputableBndrId p) - => DynFlags -> HsType (GhcPass p) -> String -outHsType dflags = out dflags . reparenType . dropHsDocTy + drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) + drop_sig_ty x@XHsSigType{} = x + + drop_lty (L src x) = L src (drop_ty x) + + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e) + drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e) + drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b) + drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b) + drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b) + drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) + drop_ty (HsListTy x a) = HsListTy x (drop_lty a) + drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c) + drop_ty (HsParTy x a) = HsParTy x (drop_lty a) + drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b + drop_ty (HsDocTy _ a _) = drop_ty $ unL a + drop_ty x = x + +outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) + => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy dropComment :: String -> String @@ -135,8 +139,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD _ d@SynDecl{}) = ppSynonym dflags d f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] f (SigD _ sig) = ppSig dflags sig f _ = [] @@ -145,8 +149,8 @@ ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of - TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names - PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names + TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where mkDocSig leader typ n = mkSubdoc dflags n subdocs @@ -155,9 +159,9 @@ ppSigWithDoc dflags sig subdocs = case sig of ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String +pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = - operator prettyNames ++ " :: " ++ outHsType dflags typ + operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names @@ -250,7 +254,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ + outHsSigType dflags (unL $ mkEmptySigType $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. @@ -269,7 +274,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty) name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d0528322..3a774ace 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -210,10 +210,10 @@ processExports (e : es) = processExport e $$ processExports es -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -296,7 +296,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -308,7 +308,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigTypeI typ) unicode + ppFunSig doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -343,9 +343,9 @@ ppFamDecl doc instances decl unicode = -- Individual equations of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) @@ -396,7 +396,7 @@ ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name @@ -411,7 +411,7 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI +ppFunSig :: DocForDecl DocName -> [DocName] -> LHsSigType DocNameI -> Bool -> LaTeX ppFunSig doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc @@ -437,12 +437,12 @@ ppLPatSig doc docnames ty unicode ) unicode where - typ = unLoc (hsSigTypeI ty) + typ = unLoc ty names = map getName docnames -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. -ppTypeOrFunSig :: HsType DocNameI +ppTypeOrFunSig :: HsSigType DocNameI -> DocForDecl DocName -- ^ documentation -> ( LaTeX -- first-line (no-argument docs only) , LaTeX -- first-line (argument docs only) @@ -462,13 +462,24 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) -> LaTeX -- ^ seperator (beginning of first line) -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) -ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ +ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ where + do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> + [ ( decltt leader + , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) + <+> ppLType unicode ltype + ) ] + HsOuterImplicit{} -> do_largs n leader ltype + + do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs @@ -505,12 +516,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = text "\\{" -ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode - <+> ppType unicode ty + <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX +ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty +ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of @@ -617,7 +632,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode + vcat [ ppFunSig doc names (dropWildCards typ) unicode | L _ (TypeSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -793,7 +808,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode (getGADTConType con) + , ppLSigType unicode (getGADTConType con) ] fieldPart = case con of @@ -868,18 +883,16 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppLType unicode (hsSigTypeI typ) + , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r - | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] - patTy = hsSigTypeI typ - mDoc = fmap _doc $ combineDocumentation doc @@ -1000,12 +1013,18 @@ ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX +ppLSigType unicode y = ppSigType unicode (unLoc y) + ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX +ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode + ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> @@ -1038,6 +1057,11 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode + = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode + , ppr_mono_lty ltype unicode ] + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d80f8e95..8b9739f1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -62,9 +62,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode pkg qual + (dropWildCards lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigTypeI lty) fixities splice unicode pkg qual + lty fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml @@ -72,25 +72,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where - pp_typ = ppLType unicode qual HideEmptyContexts typ + pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -- ^ names of patterns in declaration - -> LHsType DocNameI -- ^ type of patterns in declaration + -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = @@ -101,7 +101,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> + [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = @@ -118,7 +118,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html @@ -139,15 +139,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl] -ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where + do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype + HsOuterImplicit{} -> do_largs n leader ltype + where + leader' bndrs = leader <+> ppForAll (mkHsForAllInvisTeleI bndrs) unicode qual + argDoc n = Map.lookup n argDocs + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] @@ -239,7 +248,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -250,13 +259,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where + sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -276,13 +286,13 @@ ppTyName = ppName Prefix ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan - -> [DocName] -> HsType DocNameI + -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual emptyCtxts typ + ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names @@ -322,9 +332,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing @@ -518,7 +528,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigTypeI typ) + [ ppFunSig summary links loc doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -568,7 +578,7 @@ 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 [name] (hsSigTypeI typ) + methodBit = subMethods [ ppFunSig summary links loc doc [name] typ subfixs splice unicode pkg qual | L _ (ClassOpSig _ _ lnames typ) <- lsigs , name <- map unLoc lnames @@ -692,7 +702,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames - L _ rtyp = hsSigWcType typ + L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp @@ -755,7 +765,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -863,7 +873,7 @@ ppShortConstrParts summary dataInst con unicode qual -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} -> - ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) @@ -933,7 +943,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] @@ -1037,18 +1047,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = [] - | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigTypeI typ - emptyCtxt = patSigContext patTy + emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration. @@ -1102,6 +1111,9 @@ ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html +ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) + ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1110,6 +1122,9 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html +ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts + ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> @@ -1144,10 +1159,12 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType DocNameI -> HideEmptyContexts -patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts - | otherwise = HideEmptyContexts +patSigContext :: LHsSigType DocNameI -> HideEmptyContexts +patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where + typ = sig_body (unLoc sig_typ) + hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s @@ -1164,9 +1181,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value) -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ = - let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ + +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag + => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html +ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of + HsOuterImplicit{} -> noHtml + HsOuterExplicit{hso_bndrs = bndrs} -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of @@ -1176,6 +1200,10 @@ ppForAllPart unicode qual tele = case tele of HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts + = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts + ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c0347e56..2f342ba4 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -58,7 +58,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) - +import Haddock.Utils ( mkEmptySigType ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -104,15 +104,14 @@ tyThingToLHsDecl prr t = case t of extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = - TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) - , hsib_body = FamEqn + TyFamInstDecl $ FamEqn { feqn_ext = noExtField , feqn_tycon = fdLName fd - , feqn_bndrs = Nothing + , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd - , feqn_rhs = synifyType WithinType [] rhs }} + , feqn_rhs = synifyType WithinType [] rhs } extractAtItem :: ClassATItem @@ -170,14 +169,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType [] rhs - in HsIB { hsib_ext = map tyVarName tkvs - , hsib_body = FamEqn { feqn_ext = noExtField - , feqn_tycon = name - , feqn_bndrs = Nothing + outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually - , feqn_pats = map HsValArg annot_typats - , feqn_fixity = synifyFixity name - , feqn_rhs = hs_rhs } } + in FamEqn { feqn_ext = noExtField + , feqn_tycon = name + , feqn_bndrs = outer_bndrs + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name + , feqn_rhs = hs_rhs } where fam_tvs = tyConVisibleTyVars tc @@ -371,6 +370,12 @@ synifyDataCon use_gadt_syntax dc = (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + outer_bndrs | null user_tvbndrs + = HsOuterImplicit { hso_ximplicit = [] } + | otherwise + = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = map synifyTyVarBndr user_tvbndrs } + -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing | otherwise = Just $ synifyCtx theta @@ -407,10 +412,9 @@ synifyDataCon use_gadt_syntax dc = then do let hat = mk_gadt_arg_tys return $ noLoc $ ConDeclGADT - { con_g_ext = [] + { con_g_ext = noExtField , con_names = [name] - , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyTyVarBndr user_tvbndrs + , con_bndrs = noLoc outer_bndrs , con_mb_cxt = ctx , con_g_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -531,17 +535,17 @@ data SynifyTypeState synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn --- The empty binders is a bit suspicious; --- what if the type has free variables? -synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) +-- The use of mkEmptySigType (which uses empty binders in OuterImplicit) +-- is a bit suspicious; what if the type has free variables? +synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) -synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) +synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'. diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index d6d12e4e..39d6d3fd 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -123,30 +123,28 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing -hsImplicitBodyI (HsIB { hsib_body = body }) = body - -hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI -hsSigTypeI = hsImplicitBodyI - mkHsForAllInvisTeleI :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI +mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI +mkHsImplicitSigTypeI body = + HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField} + , sig_body = body } + +getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConType (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs +getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTeleI qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLoc (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) @@ -188,19 +186,17 @@ tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn +getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs +getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTele qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLoc (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) @@ -244,7 +240,9 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a +reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => Precedence -> HsType a -> HsType a reparenTypePrec = go where @@ -294,15 +292,37 @@ reparenTypePrec = go -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a +reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a +reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => LHsType a -> LHsType a reparenLType = mapXRec @a reparenType +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') +reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsSigType a -> HsSigType a +reparenSigType (HsSig x bndrs body) = + HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) +reparenSigType v@XHsSigType{} = v + +-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') +reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a +reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp +reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) +reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v + -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) +reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) @@ -311,13 +331,17 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) = reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a +reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ecaf1a5d..a0e56f07 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -422,7 +422,7 @@ mkMaps dflags pkgName gre instances decls = do -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) + TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -904,26 +904,23 @@ extractDecl declMap name decl | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_tycon = L _ n + InstD _ (DataFamInstD _ (DataFamInstDecl + (FamEqn { feqn_tycon = L _ n , feqn_pats = tys - , feqn_rhs = defn }}))) -> + , feqn_rhs = defn }))) -> if isDataConName name then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_rhs = dd - } - })) <- insts + let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + let matches = [ d' | L _ d'@(DataFamInstDecl d) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) @@ -963,7 +960,7 @@ extractPatternSyn nm t tvs cons = ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') - in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index e7d19dfe..a1e712e0 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -191,10 +191,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -renameLSigType = renameImplicit renameLType +renameLSigType = mapM renameSigType renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) -renameLSigWcType = renameWc (renameImplicit renameLType) +renameLSigWcType = renameWc renameLSigType renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType @@ -294,6 +294,12 @@ renameType t = case t of HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy a -> pure (HsWildCardTy a) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) +renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do + bndrs' <- renameOuterTyVarBndrs bndrs + body' <- renameLType body + pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } + -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: -- @@ -486,21 +492,20 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars +renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs , con_mb_cxt = lcontext, con_g_args = details - , con_res_ty = res_ty, con_forall = forall + , con_res_ty = res_ty , con_doc = mbldoc } = do lnames' <- mapM renameL lnames - ltyvars' <- mapM renameLTyVarBndr ltyvars + bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc return (ConDeclGADT - { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' + { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs' , con_mb_cxt = lcontext', con_g_args = details' - , con_res_ty = res_ty', con_doc = mbldoc' - , con_forall = forall}) -- Remove when #18311 is fixed + , con_res_ty = res_ty', con_doc = mbldoc' }) renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) @@ -618,32 +623,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) ; return (TyFamInstDecl { tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) -renameTyFamInstEqn eqn - = renameImplicit rename_ty_fam_eqn eqn - where - rename_ty_fam_eqn - :: FamEqn GhcRn (LHsType GhcRn) - -> RnM (FamEqn DocNameI (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs - , feqn_pats = pats, feqn_fixity = fixity - , feqn_rhs = rhs }) - = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLTypeArg pats - ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) } +renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) - = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + = do { eqn' <- rename_data_fam_eqn eqn ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn @@ -653,7 +652,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExtField @@ -663,13 +662,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_fixity = fixity , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GhcRn in_thing - -> RnM (HsImplicitBndrs DocNameI out_thing) -renameImplicit rn_thing (HsIB { hsib_body = thing }) - = do { thing' <- rn_thing thing - ; return (HsIB { hsib_body = thing' - , hsib_ext = noExtField }) } +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> RnM (HsOuterTyVarBndrs flag DocNameI) +renameOuterTyVarBndrs (HsOuterImplicit{}) = + pure $ HsOuterImplicit{hso_ximplicit = noExtField} +renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = + HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 35e5258f..b19f52d0 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -56,7 +56,7 @@ specialize specs = go spec_map0 -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn +specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where @@ -77,13 +77,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noExtField lnames (typ {hswc_body = noLoc typ'}) where - true_type :: HsType GhcRn - true_type = unLoc (hsSigWcType typ) - typ' :: HsType GhcRn + true_type :: HsSigType GhcRn + true_type = unLoc (dropWildCards typ) + typ' :: HsSigType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type - fv = foldr Set.union Set.empty . map freeVariables $ typs + fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig @@ -207,25 +207,37 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type. -freeVariables :: HsType GhcRn -> Set Name -freeVariables = - everythingWithState Set.empty Set.union query +-- | Compute set of free variables of a given 'HsType'. +freeVariablesType :: HsType GhcRn -> Set Name +freeVariablesType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType) + +-- | Compute set of free variables of a given 'HsType'. +freeVariablesSigType :: HsSigType GhcRn -> Set Name +freeVariablesSigType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType) + +queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name) +queryType term ctx = case term of + HsForAllTy _ tele _ -> + (Set.empty, Set.union ctx (teleNames tele)) + HsTyVar _ _ (L _ name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) + _ -> (Set.empty, ctx) where - query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name) - query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ tele _) -> - (Set.empty, Set.union ctx (teleNames tele)) - Just (HsTyVar _ _ (L _ name)) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getName name, ctx) - _ -> (Set.empty, ctx) - teleNames :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name) +querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx = + (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) + +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name +bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) -- | Make given type visually unambiguous. @@ -236,12 +248,12 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: Set Name -> HsType GhcRn -> HsType GhcRn -rename fv typ = evalState (renameType typ) env +rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn +rename fv typ = evalState (renameSigType typ) env where env = RenameEnv { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv - , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ , rneCtx = Map.empty } mkPair name = (getNameRep name, name) @@ -256,6 +268,17 @@ data RenameEnv name = RenameEnv } +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn) +renameSigType (HsSig x bndrs body) = + HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body + +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn) +renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) = + HsOuterImplicit <$> mapM renameName imp_tvs +renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x <$> mapM renameLBinder exp_bndrs + renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) = HsForAllTy x diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 7e34ae8c..fc946c8e 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType - , mkT + , mkT, mkQ, extQ , combine ) where @@ -91,6 +91,21 @@ mkT f = case cast f of Just f' -> f' Nothing -> id +-- | Create generic query. +-- +-- Another function stolen from SYB package. +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + +-- | Extend a generic query by a type-specific case. +-- +-- Another function stolen from SYB package. +extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ f g a = maybe (f a) g (cast a) + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6aad5dd1..7b261f4e 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -755,9 +755,14 @@ type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon type instance XXTyClDecl DocNameI = NoExtCon -type instance XHsIB DocNameI _ = NoExtField -type instance XHsWC DocNameI _ = NoExtField -type instance XXHsImplicitBndrs DocNameI _ = NoExtCon +type instance XHsWC DocNameI _ = NoExtField + +type instance XHsOuterExplicit DocNameI _ = NoExtField +type instance XHsOuterImplicit DocNameI = NoExtField +type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon + +type instance XHsSig DocNameI = NoExtField +type instance XXHsSigType DocNameI = NoExtCon type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1177fb18..aec7f9ab 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -17,7 +17,8 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, + mkEmptySigWcType, mkEmptySigType, + addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -131,21 +132,38 @@ mkMeta x = emptyMetaDoc { _doc = x } mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) +mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptySigType ty) + +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigType lty@(L loc ty) = L loc $ case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = body } + -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = bndrs } + , sig_body = body } + _ -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} + , sig_body = lty } addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious + = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where - go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) + = L loc (HsSig { sig_ext = noExtField + , sig_bndrs = bndrs, sig_body = go_ty ty }) + + go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) = L loc (HsForAllTy { hst_xforall = noExtField - , hst_tele = tele, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + , hst_tele = tele, hst_body = go_ty ty }) + go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) + go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 3477d89d..2a44be99 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -280,12 +280,12 @@ forall a. a -> a instance instance Foo] where - bar :: [a] -> Int + > where bar = [a] -> Int -forall (t :: * -> *) a. Foldable t => t a -> Int + >bar :: [a] -> Int lengthbar + > = [a] -> Int +forall (t :: * -> *) a. Foldable t => t a -> Int length baz :: Int -> ([a], [a]) + > baz Int + >baz :: Int -> ([a], [a]) _baz = ([], []) Int +_ = ([], []) instance instance ] where - quux :: ([a], [a]) -> [a] + > where quux = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a] -forall a b c. (a -> b -> c) -> (a, b) -> c + >quux :: ([a], [a]) -> [a] uncurryquux [a] -> [a] -> [a] + > = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a] +forall a b c. (a -> b -> c) -> (a, b) -> c +uncurry [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] (++)(++) @@ -941,23 +941,23 @@ forall a. [a] -> [a] -> [a] > plugh :: plugh :: p Date: Thu, 30 Jul 2020 14:00:19 -0400 Subject: Add type arguments to PrefixCon --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 4 ++-- 7 files changed, 13 insertions(+), 13 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 44841bc5..1f55db10 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -244,9 +244,9 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where - f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] - f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat + f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] + f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 3a774ace..f9480a47 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -784,7 +784,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc @@ -823,7 +823,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- H98 record declarations RecCon (L _ fields) -> doRecordFields fields -- H98 prefix data constructors - PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- H98 infix data constructor InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8b9739f1..e9806471 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -845,7 +845,7 @@ ppShortConstrParts summary dataInst con unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args -> + PrefixCon _ args -> ( header_ +++ hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args) , noHtml @@ -918,7 +918,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ +++ ppOcc <+> fixity | otherwise -> hsep [ header_ +++ ppOcc , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args) @@ -959,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- H98 record declarations RecCon (L _ fields) -> [ doRecordFields fields ] -- H98 prefix data constructors - PrefixCon args | hasArgDocs -> [ doConstrArgsWithDocs args ] + PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] -- H98 infix data constructor InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] _ -> [] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5f9940fc..b59602b6 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -398,7 +398,7 @@ synifyDataCon use_gadt_syntax dc = mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) + (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) _ -> Left "synifyDataCon: infix with non-2 args?" diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a0e56f07..8bc8d306 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -948,7 +948,7 @@ extractPatternSyn nm t tvs cons = let args = case con of ConDeclH98 { con_args = con_args' } -> case con_args' of - PrefixCon args' -> map hsScaledThing args' + PrefixCon _ args' -> map hsScaledThing args' RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] ConDeclGADT { con_g_args = con_args' } -> case con_args' of diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index a1e712e0..5d7b4f1a 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -516,7 +516,7 @@ renameH98Details :: HsConDeclH98Details GhcRn renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) -renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps +renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index aec7f9ab..8186e3b7 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -210,10 +210,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] ConDeclGADT { con_g_args = args } -> restrict_gadt_args args where restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn) - restrict_h98_args (PrefixCon _) = Just d + restrict_h98_args (PrefixCon _ _) = Just d restrict_h98_args (RecCon (L _ fields)) | all field_avail fields = Just d - | otherwise = Just (d { con_args = PrefixCon (field_types fields) }) + | otherwise = Just (d { con_args = PrefixCon noTypeArgs (field_types 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 9b403b0f5f565674adce6c64b6942d36c3d6f7ec Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 18 Nov 2020 13:54:03 +0100 Subject: DynFlags's unit fields moved to HscEnv --- haddock-api/src/Haddock.hs | 26 +++++++++++++------------- haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++++++++++--------- haddock-api/src/Haddock/Interface.hs | 5 +++-- haddock-api/src/Haddock/Interface/Create.hs | 9 +++++---- haddock-api/src/Haddock/Options.hs | 11 ++++++----- 5 files changed, 37 insertions(+), 33 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index cb444844..3543d8e2 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -178,6 +178,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags + unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks @@ -195,7 +196,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags flags sinceQual qual packages ifaces + liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -205,7 +206,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags sinceQual qual packages [] + liftIO $ renderStep dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -254,9 +255,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption +renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags sinceQual nameQual pkgs interfaces = do +renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -265,12 +266,12 @@ renderStep dflags flags sinceQual nameQual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] +render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do +render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -283,7 +284,6 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags - pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags @@ -297,7 +297,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey - pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo unit_state flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of External -> pkgName @@ -342,7 +342,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) @@ -373,7 +373,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents pkgs odir title pkgStr + ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) @@ -383,7 +383,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir + ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual @@ -403,7 +403,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgVer = fromMaybe (makeVersion []) mpkgVer - in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1f55db10..2ef0c61b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -31,6 +31,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.State import Data.Char import Data.List @@ -46,8 +47,8 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt" @@ -56,16 +57,16 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ - concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String] -ppModule dflags iface = +ppModule :: DynFlags -> UnitState -> Interface -> [String] +ppModule dflags unit_state iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags unit_state) (ifaceInstances iface) --------------------------------------------------------------------- @@ -204,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] +ppInstance :: DynFlags -> UnitState -> ClsInst -> [String] +ppInstance dflags unit_state x = + [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] where -- As per #168, we don't want safety information about the class -- in Hoogle output. The easiest way to achieve this is to set the diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 583cacf8..be9bd09a 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -159,10 +159,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do IsBoot -> return Nothing NotBoot -> do + unit_state <- hsc_units <$> getSession out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm flags modMap instIfaceMap + runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. @@ -170,7 +171,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do -- See https://github.com/haskell/haddock/issues/469. hsc_env <- getSession let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + home_unit = hsc_home_unit hsc_env !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env , let name = gre_name gre diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8bc8d306..7ef64a94 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ import GHC.Types.SourceFile import GHC.Core.ConLike (ConLike(..)) import GHC import GHC.Driver.Ppr +import GHC.Driver.Env import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -67,11 +68,12 @@ import GHC.Unit.Module.Warnings -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. createInterface :: TypecheckedModule + -> UnitState -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do +createInterface tm unit_state flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm @@ -84,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl) + (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl) pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre @@ -164,8 +166,7 @@ createInterface tm flags modMap instIfaceMap = do | otherwise = exportItems !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let !aliases = - mkAliasMap (unitState dflags) $ tm_renamed_source tm + let !aliases = mkAliasMap unit_state $ tm_renamed_source tm modWarn <- liftErrMsg (moduleWarning dflags gre warnings) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 5c9bf448..eda40935 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -45,7 +45,8 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit, unitState ) +import GHC ( DynFlags, Module, moduleUnit ) +import GHC.Unit.State import Haddock.Types import Haddock.Utils import GHC.Unit.State @@ -370,16 +371,16 @@ optLast xs = Just (last xs) -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present. -modulePackageInfo :: DynFlags +modulePackageInfo :: UnitState -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) -modulePackageInfo dflags flags (Just modu) = +modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing) +modulePackageInfo unit_state flags (Just modu) = ( optPackageName flags <|> fmap unitPackageName pkgDb , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) + pkgDb = lookupUnit unit_state (moduleUnit modu) -- cgit v1.2.3 From 600e076140649cb392d063ad73eb015630f62ff1 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 2 Dec 2020 12:37:25 +0100 Subject: Fix after binder collect changes --- haddock-api/src/Haddock/GhcUtils.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Types.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 42dc7f4f..fe97dee0 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -165,7 +165,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType" getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] getMainDeclBinderI (ValD _ d) = - case collectHsBindBinders d of + case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinderI (SigD _ d) = sigNameNoLoc d diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7ef64a94..060bef91 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -842,7 +842,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) - | name:_ <- collectHsBindBinders valDecl + | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 53a91cf5..465d276e 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -301,7 +301,7 @@ data DocNameI type instance IdP DocNameI = DocName instance CollectPass DocNameI where - collectXXPat _ ext = noExtCon ext + collectXXPat _ _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name -- cgit v1.2.3 From 8a5ccf93c53a40abe42134c2282ac9b9d653224c Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Tue, 1 Dec 2020 09:17:04 +0000 Subject: Adapt to changes to GlobalRdrElt and AvailInfo Needed for ghc/ghc!4467 --- haddock-api/src/Haddock/Interface.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 12 ++---------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 4 ++-- 3 files changed, 6 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index be9bd09a..e9cd6e0d 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -61,7 +61,7 @@ import GHC.Data.FastString (unpackFS) import GHC.Tc.Types (tcg_rdr_env) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts) +import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs @@ -174,7 +174,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do home_unit = hsc_home_unit hsc_env !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env - , let name = gre_name gre + , let name = greMangledName gre , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7ef64a94..e3263f9d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -293,7 +293,7 @@ mkWarningMap dflags warnings gre exps = case warnings of let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -693,16 +693,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail -availExportsDecl :: AvailInfo -> Bool -availExportsDecl (AvailTC ty_name names _) - | n : _ <- names = ty_name == n - | otherwise = False -availExportsDecl _ = True - availSubordinates :: AvailInfo -> [Name] -availSubordinates avail = - filter (/= availName avail) (availNamesWithSelectors avail) +availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail = diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2c06438f..44c02875 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -120,7 +120,7 @@ rename dflags gre = rn -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (greMangledName a)) -- There are multiple names available. gres -> ambiguous dflags x gres @@ -182,7 +182,7 @@ ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by hiding some imports.\n" ++ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt -- cgit v1.2.3 From d1e3e365cc4cdf086e1ad6c192db80d4e91563d2 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Fri, 25 Dec 2020 13:57:56 +0100 Subject: Prepare Haddock for being a GHC Plugin --- haddock-api/src/Haddock/Interface.hs | 8 +- haddock-api/src/Haddock/Interface/Create.hs | 247 ++++++++++++++++++++++++---- 2 files changed, 222 insertions(+), 33 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 81c79cdf..a0ba001f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -163,9 +163,15 @@ processModule verbosity modsum flags modMap instIfaceMap = do NotBoot -> do unit_state <- hsc_units <$> getSession out verbosity verbose "Creating interface..." + + let + mod_summary = pm_mod_summary (tm_parsed_module tm) + tcg_gbl_env = fst (tm_internals_ tm) + (interface, msgs) <- {-# SCC createIterface #-} withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap + runWriterGhc $ createInterface1 flags unit_state + mod_summary tcg_gbl_env modMap instIfaceMap -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e3263f9d..8bf9d7d6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} @@ -18,7 +18,7 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- -module Haddock.Interface.Create (createInterface) where +module Haddock.Interface.Create (createInterface, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Types @@ -37,6 +37,7 @@ import Data.Maybe import Control.Monad import Data.Traversable +import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module @@ -64,6 +65,191 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.Module.Warnings +createInterface1 + :: [Flag] + -> UnitState + -> ModSummary + -> TcGblEnv + -> IfaceMap + -> InstIfaceMap + -> ErrMsgGhc Interface +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do + + let + ModSummary + { + -- Cached flags from OPTIONS, INCLUDE and LANGUAGE + -- pragmas in the modules source code. Used to infer + -- safety of module. + ms_hspp_opts + , ms_location = ModLocation + { + ml_hie_file + } + } = mod_sum + + TcGblEnv + { + tcg_mod + , tcg_src + , tcg_semantic_mod + , tcg_rdr_env + , tcg_exports + , tcg_insts + , tcg_fam_insts + , tcg_warns + + -- Renamed source + , tcg_rn_imports + , tcg_rn_exports + , tcg_rn_decls + + , tcg_doc_hdr + } = tc_gbl_env + + dflags = ms_hspp_opts + + is_sig = tcg_src == HsigFile + + (pkg_name_fs, _) = + modulePackageInfo unit_state flags (Just tcg_mod) + + pkg_name :: Maybe Package + pkg_name = + let + unpack (PackageName name) = unpackFS name + in + fmap unpack pkg_name_fs + + fixities :: FixMap + fixities = case tcg_rn_decls of + Nothing -> mempty + Just dx -> mkFixMap dx + + -- Locations of all the TH splices + loc_splices :: [SrcSpan] + loc_splices = case tcg_rn_decls of + Nothing -> [] + Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] + + decls <- case tcg_rn_decls of + Nothing -> do + liftErrMsg $ tell [ "Warning: Renamed source is not available" ] + pure [] + Just dx -> + pure (topDecls dx) + + -- Derive final options to use for haddocking this module + doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod + + let + -- All elements of an explicit export list, if present + export_list :: Maybe [(IE GhcRn, Avails)] + export_list + | OptIgnoreExports `elem` doc_opts = + Nothing + | Just rn_exports <- tcg_rn_exports = + Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ] + | otherwise = + Nothing + + -- All the exported Names of this module. + exported_names :: [Name] + exported_names = + concatMap availNamesWithSelectors tcg_exports + + -- Module imports of the form `import X`. Note that there is + -- a) no qualification and + -- b) no import list + imported_modules :: Map ModuleName [ModuleName] + imported_modules + | Just{} <- export_list = + unrestrictedModuleImports (map unLoc tcg_rn_imports) + | otherwise = + M.empty + + -- TyThings that have instances defined in this module + local_instances :: [Name] + local_instances = + [ name + | name <- map getName tcg_insts ++ map getName tcg_fam_insts + , nameIsLocalOrFrom tcg_semantic_mod name + ] + + -- Infer module safety + safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) + + -- Process the top-level module header documentation. + (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name + tcg_rdr_env safety tcg_doc_hdr + + -- Warnings on declarations in this module + decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) + + -- Warning on the module header + mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) + + let + -- Warnings in this module and transitive warnings from dependend modules + warnings :: Map Name (Doc Name) + warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) + + maps@(!docs, !arg_docs, !decl_map, _) <- + liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls) + + export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod + warnings tcg_rdr_env exported_names (map fst decls) maps fixities + imported_modules loc_splices export_list tcg_exports inst_ifaces dflags + + let + visible_names :: [Name] + visible_names = mkVisibleNames maps export_items doc_opts + + -- Measure haddock documentation coverage. + pruned_export_items :: [ExportItem GhcRn] + pruned_export_items = pruneExportItems export_items + + !haddockable = 1 + length export_items -- module + exports + !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items + + coverage :: (Int, Int) + !coverage = (haddockable, haddocked) + + aliases :: Map Module ModuleName + aliases = mkAliasMap unit_state tcg_rn_imports + + return $! Interface + { + ifaceMod = tcg_mod + , ifaceIsSig = is_sig + , ifaceOrigFilename = msHsFilePath mod_sum + , ifaceHieFile = Just ml_hie_file + , ifaceInfo = info + , ifaceDoc = Documentation header_doc mod_warning + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = doc_opts + , ifaceDocMap = docs + , ifaceArgMap = arg_docs + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = if OptPrune `elem` doc_opts then + pruned_export_items else export_items + , ifaceRnExportItems = [] + , ifaceExports = exported_names + , ifaceVisibleExports = visible_names + , ifaceDeclMap = decl_map + , ifaceFixMap = fixities + , ifaceModuleAliases = aliases + , ifaceInstances = tcg_insts + , ifaceFamInstances = tcg_fam_insts + , ifaceOrphanInstances = [] -- Filled in attachInstances + , ifaceRnOrphanInstances = [] -- Filled in attachInstances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warnings + , ifaceDynFlags = dflags + } + + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. @@ -166,7 +352,7 @@ createInterface tm unit_state flags modMap instIfaceMap = do | otherwise = exportItems !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let !aliases = mkAliasMap unit_state $ tm_renamed_source tm + let !aliases = mkAliasMap unit_state imports modWarn <- liftErrMsg (moduleWarning dflags gre warnings) @@ -204,35 +390,32 @@ createInterface tm unit_state flags modMap instIfaceMap = do -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. -mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap state mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - SrcLoc.L _ alias <- ideclAs impDecl - return $ - (lookupModuleDyn state - -- TODO: This is supremely dodgy, because in general the - -- UnitId isn't going to look anything like the package - -- qualifier (even with old versions of GHC, the - -- IPID would be p-0.1, but a package qualifier never - -- has a version number it. (Is it possible that in - -- Haddock-land, the UnitIds never have version numbers? - -- I, ezyang, have not quite understand Haddock's package - -- identifier model.) - -- - -- Additionally, this is simulating some logic GHC already - -- has for deciding how to qualify names when it outputs - -- them to the user. We should reuse that information; - -- or at least reuse the renamed imports, which know what - -- they import! - (fmap Module.fsToUnit $ - fmap sl_fs $ ideclPkgQual impDecl) - (case ideclName impDecl of SrcLoc.L _ name -> name), - alias)) - impDecls +mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName +mkAliasMap state impDecls = + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + SrcLoc.L _ alias <- ideclAs impDecl + return $ + (lookupModuleDyn state + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! + (fmap Module.fsToUnit $ + fmap sl_fs $ ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls -- We want to know which modules are imported without any qualification. This -- way we can display module reexports more compactly. This mapping also looks -- cgit v1.2.3 From 703e5f0263dfc7c3173cf8ae1348c14902b9bcd7 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Thu, 7 Jan 2021 23:40:56 +0100 Subject: Abstract Monad for interface creation I found that when running as a plugin the lookupName function (which runs in Ghc monad) does not work correctly from the typeCheckResultAction hook. Instead, we abstracted the monad used when creating interfaces, so that access to GHC session specific parts is explicit and so that the TcM can provide their (correct) implementation of lookupName. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 9 - haddock-api/src/Haddock/Interface.hs | 32 ++- haddock-api/src/Haddock/Interface/Create.hs | 335 ++++++++++-------------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 3 +- haddock-api/src/Haddock/Interface/Rename.hs | 1 - haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Options.hs | 3 +- haddock-api/src/Haddock/Types.hs | 67 ++--- 10 files changed, 180 insertions(+), 275 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index cea9c4bd..87761ff8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -61,6 +61,7 @@ library , exceptions , filepath , ghc-boot + , mtl , transformers hs-source-dirs: src diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 2ba0bf52..d95c86b2 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,7 +39,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List (sort) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 452cb6f4..0a0211c9 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -34,7 +34,6 @@ import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC -import GHC.Core.Class import GHC.Driver.Session import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder @@ -403,14 +402,6 @@ modifySessionDynFlags f = do return () --- Extract the minimal complete definition of a Name, if one exists -minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) -minimalDef n = do - mty <- lookupGlobalName n - case mty of - Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c - _ -> return Nothing - ------------------------------------------------------------------------------- -- * DynFlags ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 87ac4861..c557968f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -61,8 +61,9 @@ import GHC hiding (verbosity) import GHC.Driver.Env import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) import GHC.Data.FastString (unpackFS) -import GHC.Tc.Types (TcGblEnv(..)) -import GHC.Tc.Utils.Monad (getTopEnv) +import GHC.Tc.Types (TcM, TcGblEnv(..)) +import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) @@ -202,15 +203,16 @@ plugin verbosity flags instIfaceMap = liftIO $ do moduleSetRef <- newIORef emptyModuleSet let - processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc () + processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () processTypeCheckedResult mod_summary tc_gbl_env -- Don't do anything for hs-boot modules | IsBoot <- isBootSummary mod_summary = pure () | otherwise = do + hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef (iface, modules) <- withTimingD "processModule" (const ()) $ - processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do atomicModifyIORef' ifaceMapRef $ \xs -> @@ -227,11 +229,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do paPlugin = defaultPlugin { renamedResultAction = keepRenamedSource - , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do - session <- getTopEnv >>= liftIO . newIORef - liftIO $ reflectGhc - (processTypeCheckedResult mod_summary tc_gbl_env) - (Session session) + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do + processTypeCheckedResult mod_summary tc_gbl_env pure tc_gbl_env } @@ -246,33 +245,32 @@ plugin verbosity flags instIfaceMap = liftIO $ do ) - processModule1 :: Verbosity -> [Flag] -> IfaceMap -> InstIfaceMap + -> HscEnv -> ModSummary -> TcGblEnv - -> Ghc (Interface, ModuleSet) -processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do + -> TcM (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do out verbosity verbose "Creating interface..." let TcGblEnv { tcg_rdr_env } = tc_gbl_env - unit_state <- hsc_units <$> getSession + unit_state = hsc_units hsc_env (!interface, messages) <- {-# SCC createInterface #-} - withTimingD "createInterface" (const ()) $ - runWriterGhc $ createInterface1 flags unit_state - mod_summary tc_gbl_env ifaces inst_ifaces + withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env + ifaces inst_ifaces -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. -- -- See https://github.com/haskell/haddock/issues/469. - hsc_env <- getSession let mods :: ModuleSet !mods = mkModuleSet diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8bf9d7d6..30fb8b7e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -18,43 +20,42 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- -module Haddock.Interface.Create (createInterface, createInterface1) where +module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) -import Haddock.Types +import Haddock.Types hiding (liftErrMsg) import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Data.Bifunctor +import Control.Monad.Reader +import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Control.Monad import Data.Traversable import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile +import GHC.Core.Class import GHC.Core.ConLike (ConLike(..)) -import GHC +import GHC hiding (lookupName) import GHC.Driver.Ppr -import GHC.Driver.Env import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State import GHC.Types.Name.Reader -import GHC.Tc.Types +import GHC.Tc.Types hiding (IfM) import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.SourceText @@ -65,14 +66,68 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.Module.Warnings +newtype IfEnv m = IfEnv + { + -- | Lookup names in the enviroment. + ife_lookup_name :: Name -> m (Maybe TyThing) + } + + +-- | A monad in which we create Haddock interfaces. Not to be confused with +-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. +-- +-- In the past `createInterface` was running in the `Ghc` monad but proved hard +-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting +-- over the Ghc specific clarifies where side effects happen. +newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + + +deriving newtype instance Functor m => Functor (IfM m) +deriving newtype instance Applicative m => Applicative (IfM m) +deriving newtype instance Monad m => Monad (IfM m) +deriving newtype instance MonadIO m => MonadIO (IfM m) +deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) +deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m) + + +-- | Run an `IfM` action. +runIfM + -- | Lookup a global name in the current session. Used in cases + -- where declarations don't + :: (Name -> m (Maybe TyThing)) + -- | The action to run. + -> IfM m a + -- | Result and accumulated error/warning messages. + -> m (a, [ErrMsg]) +runIfM lookup_name action = do + let + if_env = IfEnv + { + ife_lookup_name = lookup_name + } + runWriterT (runReaderT (unIfM action) if_env) + + +liftErrMsg :: Monad m => ErrMsgM a -> IfM m a +liftErrMsg action = do + writer (runWriter action) + + +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- asks ife_lookup_name + lift $ lift (lookup_name name) + + createInterface1 - :: [Flag] + :: MonadIO m + => [Flag] -> UnitState -> ModSummary -> TcGblEnv -> IfaceMap -> InstIfaceMap - -> ErrMsgGhc Interface + -> IfM m Interface createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do let @@ -134,7 +189,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do decls <- case tcg_rn_decls of Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available" ] + tell [ "Warning: Renamed source is not available" ] pure [] Just dx -> pure (topDecls dx) @@ -250,142 +305,6 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do } --- | Use a 'TypecheckedModule' to produce an 'Interface'. --- To do this, we need access to already processed modules in the topological --- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule - -> UnitState - -> [Flag] -- Boolean flags - -> IfaceMap -- Locally processed modules - -> InstIfaceMap -- External, already installed interfaces - -> ErrMsgGhc Interface -createInterface tm unit_state flags modMap instIfaceMap = do - - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - L _ hsm = parsedSource tm - !safety = modInfoSafe mi - mdl = ms_mod ms - sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) - is_sig = ms_hsc_src ms == HsigFile - dflags = ms_hspp_opts ms - !instances = modInfoInstances mi - !fam_instances = md_fam_insts md - !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl) - pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS - - (TcGblEnv { tcg_rdr_env = gre - , tcg_warns = warnings - , tcg_exports = all_exports - }, md) = tm_internals_ tm - - -- The 'pkgName' is necessary to decide what package to mention in "@since" - -- annotations. Not having it is not fatal though. - -- - -- Cabal can be trusted to pass the right flags, so this warning should be - -- mostly encountered when running Haddock outside of Cabal. - when (isNothing pkgName) $ - liftErrMsg $ tell [ "Warning: Package name is not available." ] - - -- The renamed source should always be available to us, but it's best - -- to be on the safe side. - (group_, imports, mayExports, mayDocHeader) <- - case renamedSource tm of - Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, [], Nothing, Nothing) - Just x -> return x - - opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - - -- Process the top-level module header documentation. - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - - exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 - - unrestrictedImportedMods - -- module re-exports are only possible with - -- explicit export list - | Just{} <- exports - = unrestrictedModuleImports (map unLoc imports) - | otherwise = M.empty - - fixMap = mkFixMap group_ - (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances - -- Locations of all TH splices - splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] - - warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - - maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) - - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - - -- The MAIN functionality: compute the export items which will - -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre - exportedNames decls maps fixMap unrestrictedImportedMods - splices exports all_exports instIfaceMap dflags - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- Measure haddock documentation coverage. - let prunedExportItems0 = pruneExportItems exportItems - !haddockable = 1 + length exportItems -- module + exports - !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - !coverage = (haddockable, haddocked) - - -- Prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems' - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems - !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - - let !aliases = mkAliasMap unit_state imports - - modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - - return $! Interface { - ifaceMod = mdl - , ifaceIsSig = is_sig - , ifaceOrigFilename = msHsFilePath ms - , ifaceInfo = info - , ifaceDoc = Documentation mbDoc modWarn - , ifaceRnDoc = Documentation Nothing Nothing - , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty - , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] - , ifaceExports = exportedNames - , ifaceVisibleExports = visibleNames - , ifaceDeclMap = declMap - , ifaceFixMap = fixMap - , ifaceModuleAliases = aliases - , ifaceInstances = instances - , ifaceFamInstances = fam_instances - , ifaceOrphanInstances = [] -- Filled in `attachInstances` - , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceHieFile = Just $ ml_hie_file $ ms_location ms - , ifaceDynFlags = dflags - } - - -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -640,7 +559,8 @@ mkFixMap group_ = -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: Bool -- is it a signature + :: Monad m + => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module @@ -657,7 +577,7 @@ mkExportItems -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem GhcRn] + -> IfM m [ExportItem GhcRn] mkExportItems is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports @@ -699,24 +619,39 @@ mkExportItems availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature - -> IfaceMap - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> [Name] -- exported names (orig) - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> AvailInfo - -> ErrMsgGhc [ExportItem GhcRn] + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> + return . Just $ classMinimalDef c + _ -> + return Nothing + + +availExportItem + :: forall m + . Monad m + => Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> IfM m [ExportItem GhcRn] availExportItem is_sig modMap thisMod semMod warnings exportedNames (docMap, argMap, declMap, _) fixMap splices instIfaceMap dflags availInfo = declWith availInfo where - declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ] + declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ] declWith avail = do let t = availName avail r <- findDecl avail @@ -753,7 +688,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t + mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -783,7 +718,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) - -> ErrMsgGhc [ ExportItem GhcRn ] + -> IfM m [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do -- bundled pattern synonyms only make sense if the declaration is @@ -828,7 +763,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of @@ -857,10 +792,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames n = availName avail m = nameModule n - findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)] findBundledPatterns avail = do patsyns <- for constructor_names $ \name -> do - mtyThing <- liftGhcToErrMsgGhc (lookupName name) + mtyThing <- lookupName name case mtyThing of Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name) @@ -890,9 +825,9 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) +hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do - mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + mayTyThing <- lookupName t case mayTyThing of Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] @@ -911,8 +846,9 @@ hiDecl dflags t = do -- It gets the type signature from GHC and that means it's not going to -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. -hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) +hiValExportItem + :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> IfM m (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -942,12 +878,14 @@ lookupDocs avail warnings docMap argMap = -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module. -moduleExport :: Module -- ^ Module A (identity, NOT semantic) - -> DynFlags -- ^ The flags used when typechecking A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> ModuleName -- ^ The exported module - -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport + :: Monad m + => Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> IfM m [ExportItem GhcRn] -- ^ Resulting export items moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. @@ -961,9 +899,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] + liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule (moduleUnit thisMod) expMod -- Identity module! @@ -989,22 +926,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: Bool -- is it a signature - -> IfaceMap - -> Maybe Package -- this package - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment - -> [Name] -- exported names (orig) - -> [LHsDecl GhcRn] -- renamed source declarations - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> Avails - -> ErrMsgGhc [ExportItem GhcRn] +fullModuleContents + :: Monad m + => Bool -- is it a signature + -> IfaceMap + -> Maybe Package -- this package + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> IfM m [ExportItem GhcRn] fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 44c02875..87064a0f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -22,7 +23,7 @@ module Haddock.Interface.LexParseRn import GHC.Types.Avail import Control.Arrow import Control.Monad -import Data.List +import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index bfbdf392..14032d15 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,7 +29,6 @@ import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import GHC.HsToCore.Docs diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 72fcb79b..4455f0f8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -27,7 +27,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 65aacc61..04189b99 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -46,11 +46,10 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit ) +import GHC ( Module, moduleUnit ) import GHC.Unit.State import Haddock.Types import Haddock.Utils -import GHC.Unit.State import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 53a91cf5..32f14f74 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -3,6 +3,9 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -25,13 +28,16 @@ module Haddock.Types ( , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types + + -- $ Reexports + , runWriter + , tell ) where import Control.Exception -import Control.Arrow hiding ((<+>)) import Control.DeepSeq -import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) @@ -595,26 +601,7 @@ data SinceQual type ErrMsg = String -newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } - - -instance Functor ErrMsgM where - fmap f (Writer (a, msgs)) = Writer (f a, msgs) - -instance Applicative ErrMsgM where - pure a = Writer (a, []) - (<*>) = ap - -instance Monad ErrMsgM where - return = pure - m >>= k = Writer $ let - (a, w) = runWriter m - (b, w') = runWriter (k a) - in (b, w ++ w') - - -tell :: [ErrMsg] -> ErrMsgM () -tell w = Writer ((), w) +type ErrMsgM = Writer [ErrMsg] -- Exceptions @@ -637,34 +624,24 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } ---instance MonadIO ErrMsgGhc where --- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO ---er, implementing GhcMonad involves annoying ExceptionMonad and ---WarnLogMonad classes, so don't bother. -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = WriterGhc . return . runWriter --- for now, use (liftErrMsg . tell) for this ---tell :: [ErrMsg] -> ErrMsgGhc () ---tell msgs = WriterGhc $ return ( (), msgs ) +newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } -instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) +deriving newtype instance Functor ErrMsgGhc +deriving newtype instance Applicative ErrMsgGhc +deriving newtype instance Monad ErrMsgGhc +deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc +deriving newtype instance MonadIO ErrMsgGhc -instance Applicative ErrMsgGhc where - pure a = WriterGhc (return (a, [])) - (<*>) = ap -instance Monad ErrMsgGhc where - return = pure - m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (second (msgs1 ++)) (runWriterGhc (k a)) +runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg]) +runWriterGhc = runWriterT . unErrMsgGhc -instance MonadIO ErrMsgGhc where - liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = ErrMsgGhc . lift + +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = writer . runWriter ----------------------------------------------------------------------------- -- * Pass sensitive types -- cgit v1.2.3 From df96565cf1c6b7468f58d9173bbbcbefb7445b08 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 6 Feb 2021 11:39:30 -0500 Subject: Fix partial record selector warning --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 272b8f02..72f1ab62 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} @@ -687,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD _ cl@ClassDecl{}) -> do + L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ _ -> availExportDecl avail decl docs_ -- cgit v1.2.3