haddock-api 2.27.0 → 2.28.0
raw patch · 14 files changed
+234/−199 lines, 14 filesdep ~ghc
Dependency ranges changed: ghc
Files
- haddock-api.cabal +4/−4
- src/Haddock.hs +1/−1
- src/Haddock/Backends/Hoogle.hs +8/−14
- src/Haddock/Backends/Hyperlinker/Parser.hs +2/−2
- src/Haddock/Backends/Hyperlinker/Utils.hs +3/−3
- src/Haddock/Backends/LaTeX.hs +18/−17
- src/Haddock/Backends/Xhtml/Decl.hs +29/−24
- src/Haddock/Convert.hs +81/−72
- src/Haddock/GhcUtils.hs +20/−19
- src/Haddock/Interface/AttachInstances.hs +2/−2
- src/Haddock/Interface/Create.hs +13/−13
- src/Haddock/Interface/Rename.hs +35/−23
- src/Haddock/InterfaceFile.hs +2/−2
- src/Haddock/Types.hs +16/−3
haddock-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: haddock-api-version: 2.27.0+version: 2.28.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -13,7 +13,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple-tested-with: GHC==9.4.*+tested-with: GHC==9.6.* extra-source-files: CHANGES.md@@ -44,7 +44,7 @@ -- this package typically supports only single major versions build-depends: base ^>= 4.16.0- , ghc ^>= 9.4+ , ghc ^>= 9.6 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.11 , xhtml ^>= 3000.2.2@@ -180,7 +180,7 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 9.4+ build-depends: ghc ^>= 9.6 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.11 , xhtml ^>= 3000.2.2
src/Haddock.hs view
@@ -582,7 +582,7 @@ let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] | otherwise = [Opt_Haddock] dynflags' = (foldl' gopt_set dynflags extra_opts)- { backend = NoBackend+ { backend = noBackend , ghcMode = CompManager , ghcLink = NoLink }
src/Haddock/Backends/Hoogle.hs view
@@ -18,8 +18,7 @@ ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),- PromotionFlag(..), TopLevelFlag(..) )+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), TopLevelFlag(..) ) import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup@@ -32,9 +31,11 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Unit.State+import GHC.Hs.Decls (ppDataDefnHeader, pp_vanilla_decl_head) import Data.Char-import Data.List (intercalate, isPrefixOf)+import Data.Foldable (toList)+import Data.List (dropWhileEnd, intercalate, isPrefixOf) import Data.Maybe import Data.Version @@ -219,17 +220,10 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]-ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} :+ppData dflags decl@DataDecl { tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn } subdocs+ = out dflags (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn) : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where-- -- GHC gives out "data Bar =", we want to delete the equals.- -- There's no need to worry about parenthesizing infix data type names,- -- since this Outputable instance for TyClDecl gets this right already.- showData d = unwords $ if last xs == "=" then init xs else xs- where- xs = words $ out dflags d ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields...@@ -258,7 +252,7 @@ -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with.- name = commaSeparate dflags . map unL $ getConNames con+ name = commaSeparate dflags . toList $ unL <$> getConNames con tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty@@ -276,7 +270,7 @@ = concatMap (lookupCon dflags subdocs) names ++ [typeSig] where typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty- name = out dflags $ map unL names+ name = out dflags $ unL <$> names con_sig_ty = HsSig noExtField outer_bndrs theta_ty where theta_ty = case mcxt of Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -14,7 +14,7 @@ import GHC.Types.SourceText import GHC.Driver.Session import GHC.Driver.Config.Diagnostic-import GHC.Utils.Error ( pprLocMsgEnvelope )+import GHC.Utils.Error ( pprLocMsgEnvelopeDefault ) import GHC.Data.FastString ( mkFastString ) import GHC.Parser.Errors.Ppr () import qualified GHC.Types.Error as E@@ -45,7 +45,7 @@ PFailed pst -> let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in panic $ showSDoc dflags $- text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err+ text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err where initState = initParserState pflags buf start
src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -22,7 +22,7 @@ import GHC.Iface.Type import GHC.Types.Name ( getOccFS, getOccString ) import GHC.Driver.Ppr ( showSDoc )-import GHC.Types.Var ( VarBndr(..) )+import GHC.Types.Var ( VarBndr(..), visArg, invisArg, TypeOrConstraint(..) ) import System.FilePath.Posix ((</>), (<.>)) @@ -129,8 +129,8 @@ go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t- go (HFunTy w a b) = IfaceFunTy VisArg w a b- go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b+ go (HFunTy w a b) = IfaceFunTy (visArg TypeLike) w a b -- t1 -> t2+ go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) many_ty con b -- c => t go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
src/Haddock/Backends/LaTeX.hs view
@@ -24,14 +24,12 @@ import GHC.Utils.Ppr hiding (Doc, quote) import qualified GHC.Utils.Ppr as Pretty -import GHC.Types.Basic ( PromotionFlag(..), isPromoted ) import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS )-import GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory@@ -40,7 +38,8 @@ import Control.Monad import Data.Maybe import Data.List ( sort )-import Data.Void ( absurd )+import Data.List.NonEmpty ( NonEmpty (..) )+import Data.Foldable ( toList ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation)@@ -696,8 +695,8 @@ ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs DataInst dd ->- let nd = dd_ND (tcdDataDefn dd)- pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }+ let cons = dd_cons (tcdDataDefn dd)+ pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" } in pref <+> keyword "instance" <+> typ where typ = ppAppNameTypes ihdClsName ihdTypes unicode@@ -729,7 +728,6 @@ where cons = dd_cons (tcdDataDefn dataDecl)- resTy = (unLoc . head) cons body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit] @@ -737,8 +735,8 @@ | null cons , null pats = (empty,[]) | null cons = (text "where", repeat empty)- | otherwise = case resTy of- ConDeclGADT{} -> (text "where", repeat empty)+ | otherwise = case toList cons of+ L _ ConDeclGADT{} : _ -> (text "where", repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit@@ -746,7 +744,7 @@ | otherwise = Just $ text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$ text "\\haddockbeginconstrs" $$- vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$+ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders (toList cons)) $$ text "\\end{tabulary}\\par" patternBit@@ -792,9 +790,9 @@ where -- Find the name of a constructors in the decl (`getConName` always returns -- a non-empty list)- aConName = unLoc (head (getConNamesI con))+ L _ aConName :| _ = getConNamesI con - occ = map (nameOccName . getName . unLoc) $ getConNamesI con+ occ = toList $ nameOccName . getName . unLoc <$> getConNamesI con ppOcc = cat (punctuate comma (map ppBinder occ)) ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))@@ -879,8 +877,7 @@ -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = case getConNamesI con of- [] -> panic "empty con_names"- (cn:_) -> lookup (unLoc cn) subdocs >>=+ cn:|_ -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst @@ -929,9 +926,13 @@ -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars- , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode+ , tcdDataDefn = HsDataDefn { dd_cons = cons, dd_ctxt = ctxt } }) unicode = -- newtype or data- (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>+ (case cons of+ { NewTypeCon _ -> keyword "newtype"+ ; DataTypeCons False _ -> keyword "data"+ ; DataTypeCons True _ -> keyword "type" <+> keyword "data"+ }) <+> -- context ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b@@ -1120,7 +1121,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u-ppr_mono_ty (HsSpliceTy v _) _ = absurd v+ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys@@ -1156,7 +1157,7 @@ ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) -ppr_tylit :: HsTyLit -> Bool -> LaTeX+ppr_tylit :: HsTyLit DocNameI -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s) ppr_tylit (HsCharTy _ c) _ = text (show c)
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- |@@ -29,16 +30,16 @@ import Haddock.Types import Haddock.Doc (combineDocumentation) +import Data.Foldable ( toList ) import Data.List ( intersperse, sort )+import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.Map as Map import Data.Maybe-import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import GHC.Core.Type ( Specificity(..) )-import GHC.Types.Basic (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..), fromMaybeContext)-import GHC.Exts+import GHC.Exts hiding (toList) import GHC.Types.Name import GHC.Data.BooleanFormula import GHC.Types.Name.Reader ( rdrNameOcc )@@ -610,7 +611,7 @@ ] -- Minimal complete definition- minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of+ minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns]@@ -701,8 +702,8 @@ , mdoc , [subFamInstDetails iid pdecl mname]) where- nd = dd_ND (tcdDataDefn dd)- pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }+ cons = dd_cons (tcdDataDefn dd)+ pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" } pdata = pref <+> typ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where@@ -759,18 +760,18 @@ -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl pats unicode qual - | [] <- cons+ | [] <- toList cons , [] <- pats = dataHeader - | [lcon] <- cons, [] <- pats, isH98,+ | [lcon] <- toList cons, [] <- pats, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot | [] <- pats, isH98 = dataHeader- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') (toList cons) ++ pats1) | otherwise = (dataHeader <+> keyword "where")- +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)+ +++ shortSubDecls dataInst (map doGADTConstr (toList cons) ++ pats1) where dataHeader@@ -780,7 +781,7 @@ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl)- isH98 = case unLoc (head cons) of+ isH98 = flip any (unLoc <$> cons) $ \ case ConDeclH98 {} -> True ConDeclGADT{} -> False @@ -813,7 +814,7 @@ docname = tcdNameI dataDecl curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl)- isH98 = case unLoc (head cons) of+ isH98 = flip any (unLoc <$> cons) $ \ case ConDeclH98 {} -> True ConDeclGADT{} -> False @@ -825,14 +826,14 @@ whereBit | null cons , null pats = noHtml- | null cons = keyword "where"- | otherwise = if isH98 then noHtml else keyword "where"+ | isH98 = noHtml+ | otherwise = keyword "where" constrBit = subConstructors pkg qual [ ppSideBySideConstr subdocs subfixs unicode pkg qual c- | c <- cons+ | c <- toList cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)- (map unL (getConNamesI (unLoc c)))) fixities+ (unL <$> getConNamesI (unLoc c))) fixities ] patternBit = subPatterns pkg qual@@ -899,7 +900,7 @@ ) where- occ = map (nameOccName . getName . unL) $ getConNamesI con+ occ = toList $ nameOccName . getName . unL <$> getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -916,10 +917,10 @@ ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)- aConName = unL (head (getConNamesI con))+ L _ aConName :| _ = getConNamesI con fixity = ppFixities fixities qual- occ = map (nameOccName . getName . unL) $ getConNamesI con+ occ = toList $ nameOccName . getName . unL <$> getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))@@ -998,7 +999,7 @@ -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC.- mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>=+ mbDoc = lookup aConName subdocs >>= combineDocumentation . fst @@ -1083,14 +1084,18 @@ -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppDataHeader summary (DataDecl { tcdDataDefn =- HsDataDefn { dd_ND = nd+ HsDataDefn { dd_cons = cons , dd_ctxt = ctxt , dd_kindSig = ks } , tcdLName = L _ name , tcdTyVars = tvs }) unicode qual = -- newtype or data- (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })+ (case cons of+ { NewTypeCon _ -> keyword "newtype"+ ; DataTypeCons False _ -> keyword "data"+ ; DataTypeCons True _ -> keyword "type" <+> keyword "data"+ }) <+> -- context ppLContext ctxt unicode qual HideEmptyContexts <+>@@ -1263,7 +1268,7 @@ ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts-ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v+ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field@@ -1301,7 +1306,7 @@ ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n -ppr_tylit :: HsTyLit -> Html+ppr_tylit :: HsTyLit DocNameI -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_tylit (HsCharTy _ c) = toHtml (show c)
src/Haddock/Convert.hs view
@@ -20,25 +20,25 @@ ) where import GHC.Data.Bag ( emptyBag )-import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )+import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) ) import GHC.Types.SourceText (SourceText(..)) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike-import Data.Either (lefts, rights) import GHC.Core.DataCon import GHC.Core.FamInstEnv+import GHC.Core.PatSyn+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare( eqTypes )+ import GHC.Hs import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual )-import GHC.Core.PatSyn-import GHC.Tc.Utils.TcType-import GHC.Core.TyCon-import GHC.Core.Type-import GHC.Core.TyCo.Rep import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon )@@ -52,11 +52,15 @@ import GHC.Types.Var.Set import GHC.Types.SrcLoc +import Language.Haskell.Syntax.Basic (FieldLabelString(..))+ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType ) +import Data.Either (lefts, rights) import Data.Maybe ( catMaybes, mapMaybe, maybeToList )+import Data.Either ( partitionEithers ) -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check@@ -97,7 +101,7 @@ -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn- hsLTyVarBndrToType = mapLoc cvt+ hsLTyVarBndrToType = fmap cvt extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs =@@ -125,13 +129,14 @@ in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = Just $ synifyCtx (classSCTheta cl)+ , tcdLayout = NoLayoutInfo , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl , tcdFDs = map (\ (l,r) -> noLocA (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $ snd $ classTvsFds cl- , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) :+ , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) : [ noLocA tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ]@@ -198,7 +203,7 @@ -> TyCon -- ^ type constructor to convert -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon prr _coax tc- | isFunTyCon tc || isPrimTyCon tc+ | isPrimTyCon tc = return $ DataDecl { tcdLName = synifyNameN tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism@@ -210,13 +215,12 @@ , tcdFixity = synifyFixity tc , tcdDataDefn = HsDataDefn { dd_ext = noExtField- , dd_ND = DataType -- arbitrary lie, they are neither+ , dd_cons = DataTypeCons False [] -- No constructors; arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = Nothing , dd_cType = Nothing , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately:- , dd_cons = [] -- No constructors , dd_derivs = [] } , tcdDExt = DataDeclRn False emptyNameSet } where@@ -246,7 +250,7 @@ DataFamilyTyCon {} -> mkFamDecl DataFamily where- resultVar = famTcResVar tc+ resultVar = tyConFamilyResVar_maybe tc mkFamDecl i = return $ FamDecl noExtField $ FamilyDecl { fdExt = noAnn , fdInfo = i@@ -268,52 +272,52 @@ , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = synifyFixity tc , tcdRhs = synifyType WithinType [] ty }- | otherwise =+ | otherwise = do -- (closed) newtype and data- let- alg_nd = if isNewTyCon tc then NewType else DataType- alg_ctx = synifyCtx (tyConStupidTheta tc)- name = case coax of- Just a -> synifyNameN a -- Data families are named according to their+ let alg_ctx = synifyCtx (tyConStupidTheta tc)+ name = case coax of+ Just a -> synifyNameN a -- Data families are named according to their -- CoAxioms, not their TyCons- _ -> synifyNameN tc- tyvars = synifyTyVars (tyConVisibleTyVars tc)- kindSig = synifyDataTyConReturnKind tc- -- The data constructors.- --- -- Any data-constructors not exported from the module that *defines* the- -- type will not (cannot) be included.- --- -- Very simple constructors, Haskell98 with no existentials or anything,- -- probably look nicer in non-GADT syntax. In source code, all constructors- -- must be declared with the same (GADT vs. not) syntax, and it probably- -- is less confusing to follow that principle for the documentation as well.- --- -- There is no sensible infix-representation for GADT-syntax constructor- -- declarations. They cannot be made in source code, but we could end up- -- with some here in the case where some constructors use existentials.- -- That seems like an acceptable compromise (they'll just be documented- -- in prefix position), since, otherwise, the logic (at best) gets much more- -- complicated. (would use dataConIsInfix.)- use_gadt_syntax = isGadtSyntaxTyCon tc- consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)- cons = rights consRaw- -- "deriving" doesn't affect the signature, no need to specify any.- alg_deriv = []- defn = HsDataDefn { dd_ext = noExtField- , dd_ND = alg_nd+ _ -> synifyNameN tc+ tyvars = synifyTyVars (tyConVisibleTyVars tc)+ kindSig = synifyDataTyConReturnKind tc+ -- The data constructors.+ --+ -- Any data-constructors not exported from the module that *defines* the+ -- type will not (cannot) be included.+ --+ -- Very simple constructors, Haskell98 with no existentials or anything,+ -- probably look nicer in non-GADT syntax. In source code, all constructors+ -- must be declared with the same (GADT vs. not) syntax, and it probably+ -- is less confusing to follow that principle for the documentation as well.+ --+ -- There is no sensible infix-representation for GADT-syntax constructor+ -- declarations. They cannot be made in source code, but we could end up+ -- with some here in the case where some constructors use existentials.+ -- That seems like an acceptable compromise (they'll just be documented+ -- in prefix position), since, otherwise, the logic (at best) gets much more+ -- complicated. (would use dataConIsInfix.)+ use_gadt_syntax = isGadtSyntaxTyCon tc+ consRaw <- case partitionEithers $ synifyDataCon use_gadt_syntax <$> tyConDataCons tc of+ ([], consRaw) -> Right consRaw+ (errs, _) -> Left (unlines errs)+ cons <- case (isNewTyCon tc, consRaw) of+ (False, cons) -> Right (DataTypeCons False cons)+ (True, [con]) -> Right (NewTypeCon con)+ (True, _) -> Left "Newtype hasn't 1 constructor"++ let -- "deriving" doesn't affect the signature, no need to specify any.+ alg_deriv = []+ defn = HsDataDefn { dd_ext = noExtField , dd_ctxt = Just alg_ctx , dd_cType = Nothing , dd_kindSig = kindSig , dd_cons = cons , dd_derivs = alg_deriv }- in case lefts consRaw of- [] -> return $- DataDecl { tcdLName = name, tcdTyVars = tyvars+ pure DataDecl { tcdLName = name, tcdTyVars = tyvars , tcdFixity = synifyFixity name , tcdDataDefn = defn , tcdDExt = DataDeclRn False emptyNameSet }- dataConErrs -> Left $ unlines dataConErrs -- | In this module, every TyCon being considered has come from an interface -- file. This means that when considering a data type constructor such as:@@ -387,7 +391,7 @@ field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLocA $- ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy+ ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)] synTy Nothing mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)@@ -410,7 +414,8 @@ let hat = mk_gadt_arg_tys return $ noLocA $ ConDeclGADT { con_g_ext = noAnn- , con_names = [name]+ , con_names = pure name+ , con_dcolon = noHsUniTok , con_bndrs = noLocA outer_bndrs , con_mb_cxt = ctx , con_g_args = hat@@ -422,7 +427,7 @@ { con_ext = noAnn , con_name = name , con_forall = False- , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs+ , con_ex_tvs = map (synifyTyVarBndr . (mkForAllTyBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing }@@ -511,7 +516,7 @@ tyConArgsPolyKinded :: TyCon -> [Bool] tyConArgsPolyKinded tc = map (is_poly_ty . tyVarKind) tc_vis_tvs- ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs+ ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs ++ repeat True where is_poly_ty :: Type -> Bool@@ -523,8 +528,8 @@ tc_vis_tvs :: [TyVar] tc_vis_tvs = tyConVisibleTyVars tc - tc_res_kind_vis_bndrs :: [TyCoBinder]- tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc+ tc_res_kind_vis_bndrs :: [PiTyBinder]+ tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc --states of what to do with foralls: data SynifyTypeState@@ -657,15 +662,18 @@ ty_head' = synifyType WithinType vs ty_head ty_args' = map (synifyType WithinType vs) $ filterOut isCoercionTy $- filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)+ filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) ty_args in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'-synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty-synifyType _ vs (FunTy VisArg w t1 t2) = let- s1 = synifyType WithinType vs t1- s2 = synifyType WithinType vs t2- w' = synifyMult vs w- in noLocA $ HsFunTy noAnn w' s1 s2++synifyType s vs funty@(FunTy af w t1 t2)+ | isInvisibleFunArg af = synifySigmaType s vs funty+ | otherwise = noLocA $ HsFunTy noAnn w' s1 s2+ where+ s1 = synifyType WithinType vs t1+ s2 = synifyType WithinType vs t2+ w' = synifyMult vs w+ synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of Required -> synifyVisForAllType vs forallty@@ -799,8 +807,8 @@ synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of- One -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)- Many -> HsUnrestrictedArrow noHsUniTok+ OneTy -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)+ ManyTy -> HsUnrestrictedArrow noHsUniTok ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok @@ -820,9 +828,9 @@ in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))- (mkVisFunTys arg_tys res_ty)+ (mkScaledFunTys arg_tys res_ty) -synifyTyLit :: TyLit -> HsTyLit+synifyTyLit :: TyLit -> HsTyLit GhcRn synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c@@ -921,7 +929,7 @@ -- | See Note [Invariant: Never expand type synonyms] tcSplitSomeForAllTysPreserveSynonyms ::- (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type)+ (ForAllTyFlag -> Bool) -> Type -> ([ForAllTyBinder], Type) tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] where split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs@@ -931,12 +939,12 @@ -- | See Note [Invariant: Never expand type synonyms] tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type) tcSplitForAllTysReqPreserveSynonyms ty =- let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleForAllTyFlag ty req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in assert ( req_bndrs `equalLength` all_bndrs) (req_bndrs, body) where- mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder+ mk_req_bndr_maybe :: ForAllTyBinder -> Maybe ReqTVBinder mk_req_bndr_maybe (Bndr tv argf) = case argf of Required -> Just $ Bndr tv () Invisible _ -> Nothing@@ -944,12 +952,12 @@ -- | See Note [Invariant: Never expand type synonyms] tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type) tcSplitForAllTysInvisPreserveSynonyms ty =- let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleForAllTyFlag ty inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in assert ( inv_bndrs `equalLength` all_bndrs) (inv_bndrs, body) where- mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder+ mk_inv_bndr_maybe :: ForAllTyBinder -> Maybe InvisTVBinder mk_inv_bndr_maybe (Bndr tv argf) = case argf of Invisible s -> Just $ Bndr tv s Required -> Nothing@@ -967,5 +975,6 @@ -- | See Note [Invariant: Never expand type synonyms] tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)-tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res)+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy af _ arg res)+ | isInvisibleFunArg af = Just (arg, res) tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
src/Haddock/GhcUtils.hs view
@@ -5,6 +5,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-}@@ -25,6 +27,8 @@ import Control.Arrow import Data.Char ( isSpace )+import Data.Foldable ( toList )+import Data.List.NonEmpty ( NonEmpty ) import Data.Maybe ( mapMaybe, fromMaybe ) import Haddock.Types( DocName, DocNameI, XRecCond )@@ -37,10 +41,9 @@ import GHC.Unit.Module import GHC import GHC.Driver.Session-import GHC.Types.Basic import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder- , tyVarKind, updateTyVarKind, isInvisibleArgFlag )+ , tyVarKind, updateTyVarKind, isInvisibleForAllTyFlag ) import GHC.Types.Var.Set ( VarSet, emptyVarSet ) import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) )@@ -76,7 +79,7 @@ case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))-filterSigNames _ orig@(MinimalSig _ _ _) = Just orig+filterSigNames _ orig@(MinimalSig _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing@@ -127,8 +130,8 @@ hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [LocatedN DocName]-getConNamesI ConDeclH98 {con_name = name} = [name]+getConNamesI :: ConDecl DocNameI -> NonEmpty (LocatedN DocName)+getConNamesI ConDeclH98 {con_name = name} = pure name getConNamesI ConDeclGADT {con_names = names} = names hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI@@ -255,21 +258,19 @@ _ -> decl restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })- | DataType <- new_or_data- = defn { dd_cons = restrictCons names cons }- | otherwise -- Newtype- = case restrictCons names cons of- [] -> defn { dd_ND = DataType, dd_cons = [] }- [con] -> defn { dd_cons = [con] }- _ -> error "Should not happen"+restrictDataDefn names d = d { dd_cons = restrictDataDefnCons names (dd_cons d) } -restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]+restrictDataDefnCons :: [Name] -> DataDefnCons (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn)+restrictDataDefnCons names = \ case+ DataTypeCons is_type_data cons -> DataTypeCons is_type_data (restrictCons names cons)+ NewTypeCon con -> maybe (DataTypeCons False []) NewTypeCon $ restrictCons names (Just con)++restrictCons :: MonadFail m => [Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)+restrictCons names decls = [ L p d | L p (Just d) <- fmap keep <$> decls ] where keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn) keep d- | any (\n -> n `elem` names) (map unLoc $ getConNames d) =+ | any (`elem` names) (unLoc <$> getConNames d) = case d of ConDeclH98 { con_args = con_args' } -> case con_args' of PrefixCon {} -> Just d@@ -471,7 +472,7 @@ instance Parent (TyClDecl GhcRn) where children d- | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc)+ | isDataDecl d = map unLoc $ concatMap (toList . getConNames . unLoc) $ (dd_cons . tcdDataDefn) d | isClassDecl d = map (unLoc . fdLName . unLoc) (tcdATs d) ++@@ -485,7 +486,7 @@ familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]-familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d)+familyConDecl d = zip (toList $ unLoc <$> getConNames d) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively.@@ -724,7 +725,7 @@ go :: TyVarEnv () -> Type -> Type go subs (ForAllTy (Bndr var flg) ty) | isRuntimeRepVar var- , isInvisibleArgFlag flg+ , isInvisibleForAllTyFlag flg = let subs' = extendVarEnv subs var () in go subs' ty | otherwise
src/Haddock/Interface/AttachInstances.hs view
@@ -40,7 +40,7 @@ import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Core.TyCo.Rep-import GHC.Builtin.Types.Prim( funTyConName )+import GHC.Builtin.Types( unrestrictedFunTyConName ) import GHC.Types.Var hiding (varName) import GHC.HsToCore.Docs @@ -209,7 +209,7 @@ argCount _ = 0 simplify :: Type -> SimpleType-simplify (FunTy _ _ t1 t2) = SimpleType (SName funTyConName) [simplify t1, simplify t2]+simplify (FunTy _ _ t1 t2) = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1
src/Haddock/Interface/Create.hs view
@@ -43,6 +43,7 @@ import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable (bitraverse)+import Data.Foldable (toList) import Data.List (find, foldl') import qualified Data.IntMap as IM import Data.IntMap (IntMap)@@ -63,7 +64,6 @@ import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail-import GHC.Types.Basic (PromotionFlag (..)) import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv)@@ -380,12 +380,12 @@ ] isInteresting idecl =- case ideclHiding idecl of+ case ideclImportList idecl of -- i) no subset selected Nothing -> True -- ii) an import with a hiding clause -- without any names- Just (True, L _ []) -> True+ Just (EverythingBut, L _ []) -> True -- iii) any other case of qualification _ -> False @@ -442,7 +442,7 @@ opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []- xs -> liftM catMaybes (mapM parseOption xs)+ xs -> fmap catMaybes (mapM parseOption xs) Nothing -> return [] pure (foldl go opts flags) where@@ -651,7 +651,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap splices instIfaceMap dflags allExports- Just exports -> liftM concat $ mapM lookupExport exports+ Just exports -> fmap concat $ mapM lookupExport exports where lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre (hsDocString . unLoc $ docStr)@@ -754,7 +754,7 @@ L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t- let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef+ let sig = maybeToList $ fmap (noLocA . MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA) mdef availExportDecl avail (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ @@ -1100,8 +1100,8 @@ , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d) lsig <- if isDataConName name- then extractPatternSyn name dataNm ty_args dataCons- else extractRecSel name dataNm ty_args dataCons+ then extractPatternSyn name dataNm ty_args (toList dataCons)+ else extractRecSel name dataNm ty_args (toList dataCons) pure (SigD noExtField <$> lsig) TyClD _ FamDecl {}@@ -1113,12 +1113,12 @@ , feqn_pats = tys , feqn_rhs = defn }))) -> if isDataConName name- then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn)- else fmap (SigD noExtField) <$> extractRecSel name n tys (dd_cons defn)+ then fmap (SigD noExtField) <$> extractPatternSyn name n tys (toList $ dd_cons defn)+ else fmap (SigD noExtField) <$> extractRecSel name n tys (toList $ dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts- , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))+ , name `elem` map unLoc (concatMap (toList . getConNames . unLoc) (dd_cons dd)) ] in case matches of [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))@@ -1126,8 +1126,8 @@ | otherwise -> 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))+ -- , L _ ConDecl { con_details = RecCon rec } <- toList $ dd_cons (feqn_rhs d)+ , Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , foExt n == name
src/Haddock/Interface/Rename.hs view
@@ -308,33 +308,29 @@ doc' <- renameLDocHsSyn doc return (HsDocTy noAnn ty' doc') - HsTyLit _ x -> return (HsTyLit noAnn x)+ HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x)) HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a XHsType a -> pure (XHsType a) HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b- HsSpliceTy _ s -> renameHsSpliceTy s+ HsSpliceTy (HsUntypedSpliceTop _ st) _ -> renameType (unLoc st)+ HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice" HsWildCardTy _ -> pure (HsWildCardTy noAnn) +renameTyLit :: HsTyLit GhcRn -> HsTyLit DocNameI+renameTyLit t = case t of+ HsNumTy _ v -> HsNumTy noExtField v+ HsStrTy _ v -> HsStrTy noExtField v+ HsCharTy _ v -> HsCharTy noExtField v + 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:------ * the input is from after GHC's renamer, so should have an 'HsSpliced'--- * the input is typechecked, and only 'HsSplicedTy' should get through that----renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)-renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t-renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy"-renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"- renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs@@ -432,7 +428,8 @@ return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdDataDefn = defn' }) - ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity+ ClassDecl { tcdLayout = layout+ , tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- traverse renameLContext lcontext lname' <- renameL lname@@ -442,10 +439,12 @@ ats' <- mapM (renameLThing renameFamilyDecl) ats at_defs' <- mapM (mapM renameTyFamDefltD) at_defs -- we don't need the default methods or the already collected doc entities- return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+ return (ClassDecl { tcdCExt = noExtField+ , tcdLayout = renameLayoutInfo layout+ , tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag- , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [] }) where renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)@@ -456,6 +455,11 @@ renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig +renameLayoutInfo :: LayoutInfo GhcRn -> LayoutInfo DocNameI+renameLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb+renameLayoutInfo (VirtualBraces n) = VirtualBraces n+renameLayoutInfo NoLayoutInfo = NoLayoutInfo+ renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars@@ -492,14 +496,14 @@ ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)-renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType+renameDataDefn (HsDataDefn { dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k cons' <- mapM (mapMA renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ext = noExtField- , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType+ , dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = [] }) @@ -519,6 +523,7 @@ , con_args = details', con_doc = mbldoc' }) renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs+ , con_dcolon = dcol , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty , con_doc = mbldoc } = do@@ -529,7 +534,8 @@ res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc return (ConDeclGADT- { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'+ { con_g_ext = noExtField, con_names = lnames'+ , con_dcolon = dcol, con_bndrs = bndrs' , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) @@ -584,9 +590,9 @@ FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig noExtField (FixitySig noExtField lnames' fixity)- MinimalSig _ src (L l s) -> do+ MinimalSig _ (L l s) -> do s' <- traverse (traverse lookupRnNoWarn) s- return $ MinimalSig noExtField src (L l s')+ return $ MinimalSig noExtField (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -595,11 +601,17 @@ renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype- return (ForeignImport noExtField lname' ltype' x)+ return (ForeignImport noExtField lname' ltype' (renameForI x)) renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype- return (ForeignExport noExtField lname' ltype' x)+ return (ForeignExport noExtField lname' ltype' (renameForE x))++renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI+renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec++renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI+renameForE (CExport _ spec) = CExport noExtField spec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
src/Haddock/InterfaceFile.hs view
@@ -123,8 +123,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)-binaryInterfaceVersion = 41+#if MIN_VERSION_ghc(9,6,0) && !MIN_VERSION_ghc(9,7,0)+binaryInterfaceVersion = 42 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
src/Haddock/Types.hs view
@@ -44,9 +44,7 @@ import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data)-import Data.Void (Void) import Documentation.Haddock.Types-import GHC.Types.Basic (PromotionFlag(..)) import GHC.Types.Fixity (Fixity(..)) import GHC.Types.Var (Specificity) @@ -322,6 +320,7 @@ instance CollectPass DocNameI where collectXXPat _ ext = dataConCantHappen ext collectXXHsBindsLR ext = dataConCantHappen ext+ collectXSplicePat _ ext = dataConCantHappen ext instance NamedThing DocName where getName (Documented name _) = name@@ -750,7 +749,7 @@ type instance XParTy DocNameI = EpAnn AnnParen type instance XIParamTy DocNameI = EpAnn [AddEpAnn] type instance XKindSig DocNameI = EpAnn [AddEpAnn]-type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`+type instance XSpliceTy DocNameI = DataConCantHappen type instance XDocTy DocNameI = EpAnn [AddEpAnn] type instance XBangTy DocNameI = EpAnn [AddEpAnn] type instance XRecTy DocNameI = EpAnn [AddEpAnn]@@ -760,6 +759,11 @@ type instance XWildCardTy DocNameI = EpAnn [AddEpAnn] type instance XXType DocNameI = HsCoreTy +type instance XNumTy DocNameI = NoExtField+type instance XStrTy DocNameI = NoExtField+type instance XCharTy DocNameI = NoExtField+type instance XXTyLit DocNameI = DataConCantHappen+ type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField type instance XXHsForAllTelescope DocNameI = DataConCantHappen@@ -780,6 +784,13 @@ type instance XForeignExport DocNameI = NoExtField type instance XForeignImport DocNameI = NoExtField++type instance XCImport DocNameI = NoExtField+type instance XCExport DocNameI = NoExtField++type instance XXForeignImport DocNameI = DataConCantHappen+type instance XXForeignExport DocNameI = DataConCantHappen+ type instance XConDeclGADT DocNameI = NoExtField type instance XConDeclH98 DocNameI = NoExtField type instance XXConDecl DocNameI = DataConCantHappen@@ -831,6 +842,8 @@ type instance XXPat DocNameI = DataConCantHappen type instance XXHsBindsLR DocNameI a = DataConCantHappen++type instance XSplicePat DocNameI = DataConCantHappen type instance XCInjectivityAnn DocNameI = NoExtField