diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -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 diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -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 } diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -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 }) diff --git a/src/Haddock/Backends/Hyperlinker/Parser.hs b/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -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 diff --git a/src/Haddock/Backends/Hyperlinker/Utils.hs b/src/Haddock/Backends/Hyperlinker/Utils.hs --- a/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -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 "" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -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) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -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) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -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 diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -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 diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -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 diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -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 diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -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) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -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] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -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