diff options
22 files changed, 269 insertions, 180 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8ef8f5ca..63ceeb16 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -282,6 +282,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags + pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags @@ -340,7 +341,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit dflags (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) @@ -371,7 +372,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents dflags' odir title pkgStr + ppHtmlContents pkgs odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) @@ -381,7 +382,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir + ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index e03611b2..27a7d804 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -71,7 +71,7 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e) + f (HsForAllTy x a e) = HsForAllTy x a (g e) f (HsQualTy x a e) = HsQualTy x a (g e) f (HsBangTy x a b) = HsBangTy x a (g b) f (HsAppTy x a b) = HsAppTy x (g a) (g b) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 41591c6e..19c72335 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -46,7 +46,7 @@ parse dflags fpath bs = case unP (go False []) initState of start = mkRealSrcLoc (mkFastString fpath) 1 1 pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags) - (thisPackage dflags) + (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 13f22db7..0c323ae5 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -474,10 +474,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ fvf tvs ltype) + do_args _n leader (HsForAllTy _ tele ltype) = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ - [ppForAllSeparator unicode fvf])) + , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) @@ -506,12 +505,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = text "\\{" -ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) @@ -519,6 +512,14 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty +ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX +ppHsForAllTelescope tele unicode = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + + ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarNameI) @@ -795,7 +796,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = , ppLType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgs con) of + fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] @@ -1040,9 +1041,8 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> - ppForAllSeparator unicode fvf +ppr_mono_ty (HsForAllTy _ tele ty) unicode + = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index cfbaffc6..24b565fc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -52,12 +52,13 @@ import Data.Ord ( comparing ) import GHC.Driver.Session (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import GHC.Types.Name +import GHC.Unit.State -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- -ppHtml :: DynFlags +ppHtml :: UnitState -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] @@ -77,7 +78,7 @@ ppHtml :: DynFlags -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue +ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do @@ -86,7 +87,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $ - ppHtmlContents dflags odir doctitle maybe_package + ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents @@ -258,7 +259,7 @@ moduleInfo iface = ppHtmlContents - :: DynFlags + :: UnitState -> FilePath -> String -> Maybe String @@ -272,14 +273,14 @@ ppHtmlContents -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () -ppHtmlContents dflags odir doctitle _maybe_package +ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do - let tree = mkModuleTree dflags showPkgs + let tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , not (instIsSig iface)] - sig_tree = mkModuleTree dflags showPkgs + sig_tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , instIsSig iface] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 76b5fae8..5163fb6b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -151,10 +151,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy _ fvf tvs ltype) + do_args n leader (HsForAllTy _ tele ltype) = do_largs n leader' ltype where - leader' = leader <+> ppForAll tvs unicode qual fvf + leader' = leader <+> ppForAll tele unicode qual do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -189,20 +189,22 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ -ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag +ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual fvf = - case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - -ppForAllSeparator :: Unicode -> ForallVisFlag -> Html -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> spaceHtml +++ arrow unicode - ForallInvis -> dot +ppForAll tele unicode qual = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + pp_bndrs bndrs (spaceHtml +++ arrow unicode) + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + pp_bndrs bndrs dot + where + pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html + pp_bndrs tvs forall_separator = + case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of + [] -> noHtml + ts -> forallSymbol unicode <+> hsep ts +++ forall_separator + + pp_ktv n k = parens $ + ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml @@ -934,7 +936,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , fixity ] - fieldPart = case (con, getConArgs con) of + fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] @@ -1146,16 +1148,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of - HsForAllTy _ _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ _ s -> hasNonEmptyContext s + HsForAllTy _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ s -> isFirstContextEmpty s _ -> False @@ -1165,19 +1167,21 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: RenderableBndrFlag flag => - Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html -ppForAllPart unicode qual fvf tvs = - hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ - ppForAllSeparator unicode fvf +ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html +ppForAllPart unicode qual tele = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ + spaceHtml +++ arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts - = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts +ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 0020fc4c..b45b6eab 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -19,6 +19,8 @@ module Haddock.Convert ( PrintRuntimeReps(..), ) where +#include "HsVersions.h" + import GHC.Data.Bag ( emptyBag ) import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) , PromotionFlag(..), DefMethSpec(..) ) @@ -44,7 +46,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import GHC.Types.Unique ( getUnique ) -import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut ) +import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength + , filterByList, filterOut ) +import GHC.Utils.Outputable ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc @@ -53,7 +57,7 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) -import Data.Maybe ( catMaybes, maybeToList ) +import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check @@ -395,7 +399,7 @@ synifyDataCon use_gadt_syntax dc = ConDeclGADT { con_g_ext = [] , con_names = [name] , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyInvisTyVar user_tvbndrs + , con_qvars = map synifyTyVarBndr user_tvbndrs , con_mb_cxt = ctx , con_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -404,7 +408,7 @@ synifyDataCon use_gadt_syntax dc = ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False - , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } @@ -450,27 +454,25 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn -synifyTyVar = synifyTyVar' emptyVarSet +synifyTyVar = synify_ty_var emptyVarSet () + +synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr = synifyTyVarBndr' emptyVarSet -synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn -synifyInvisTyVar = synifyInvisTyVar' emptyVarSet +synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv --- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind -- signatures (even if they don't have the lifted type kind). -synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn -synifyTyVar' no_kinds tv +synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn +synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExtField () (noLoc name)) - | otherwise = noLoc (KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) + = noLoc (UserTyVar noExtField flag (noLoc name)) + | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv -synifyInvisTyVar' :: VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn -synifyInvisTyVar' no_kinds (Bndr tv spec) = case (synifyTyVar' no_kinds tv) of - L l (UserTyVar ne _ n) -> L l (UserTyVar ne spec n) - L l (KindedTyVar ne _ n k) -> L l (KindedTyVar ne spec n k) - -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in @@ -626,39 +628,56 @@ synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExtField s1 s2 -synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty +synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 in noLoc $ HsFunTy noExtField s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = - synifyForAllType s argf vs forallty + case argf of + Required -> synifyVisForAllType vs forallty + Invisible _ -> synifySigmaType s vs forallty synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" --- | Process a 'Type' which starts with a forall or a constraint into --- an 'HsType' -synifyForAllType +-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType' +synifyVisForAllType + :: [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyVisForAllType vs ty = + let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty + + sTvs = map synifyTyVarBndr tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) [rho] + + in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } + +-- | Process a 'Type' which starts with an invisible @forall@ or a constraint +-- into an 'HsType' +synifySigmaType :: SynifyTypeState -- ^ what to do with the 'forall' - -> ArgFlag -- ^ the visibility of the @forall@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the forall type to convert -> LHsType GhcRn -synifyForAllType s argf vs ty = - let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty - inv_tvs = map to_invis_bndr tvs +synifySigmaType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } - sTvs = map synifyInvisTyVar inv_tvs + sTvs = map synifyTyVarBndr tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -672,12 +691,7 @@ synifyForAllType s argf vs ty = | not (null tvs) -> noLoc sTy | otherwise -> noLoc sPhi - ImplicitizeForAll -> implicitForAll [] vs inv_tvs ctx (synifyType WithinType) tau - - where - to_invis_bndr :: TyVarBinder -> InvisTVBinder - to_invis_bndr (Bndr tv Required) = Bndr tv SpecifiedSpec - to_invis_bndr (Bndr tv (Invisible spec)) = Bndr tv spec + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau -- | Put a forall in if there are any type variables which require -- explicit kind annotations or if the inferred type variable order @@ -701,13 +715,12 @@ implicitForAll tycons vs tvs ctx synInner tau = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau - sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs + sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -850,22 +863,54 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this invariant didn't hold. -} --- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms. +-- | A version of 'TcType.tcSplitSigmaTy' that: +-- +-- 1. Preserves type synonyms. +-- 2. Returns 'InvisTVBinder's instead of 'TyVar's. -- -- See Note [Invariant: Never expand type synonyms] -tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type) -tcSplitSigmaTySameVisPreserveSynonyms argf ty = - case tcSplitForAllTysSameVisPreserveSynonyms argf ty of +tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysInvisPreserveSynonyms ty of (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of (theta, tau) -> (tvs, theta, tau) -- | See Note [Invariant: Never expand type synonyms] -tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type) -tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty [] +tcSplitSomeForAllTysPreserveSynonyms :: + (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type) +tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] + where + split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs + | argf_pred argf = split ty' ty' (tvb:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type) +tcSplitForAllTysReqPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty + req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in + ASSERT( req_bndrs `equalLength` all_bndrs ) + (req_bndrs, body) where - split _ (ForAllTy tvbndr@(Bndr _ argf) ty') tvs - | argf `sameVis` supplied_argf = split ty' ty' (tvbndr:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder + mk_req_bndr_maybe (Bndr tv argf) = case argf of + Required -> Just $ Bndr tv () + Invisible _ -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type) +tcSplitForAllTysInvisPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag 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 (Bndr tv argf) = case argf of + Invisible s -> Just $ Bndr tv s + Required -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index dbe9ec3c..73a2bac6 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -34,8 +34,8 @@ import GHC import GHC.Core.Class import GHC.Driver.Session import GHC.Types.SrcLoc ( advanceSrcLoc ) -import GHC.Types.Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, - isInvisibleArgFlag ) +import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder + , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) import GHC.Types.Var.Set ( VarSet, emptyVarSet ) import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) @@ -178,6 +178,14 @@ hsImplicitBodyI (HsIB { hsib_body = body }) = body hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI hsSigTypeI = hsImplicitBodyI +mkHsForAllInvisTeleI :: + [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI +mkHsForAllInvisTeleI invis_bndrs = + HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } + +getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI +getConArgsI d = con_args d + getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So @@ -187,9 +195,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTeleI qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -233,7 +240,7 @@ tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) +getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the @@ -242,9 +249,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTele qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -306,8 +312,8 @@ reparenTypePrec = go go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) go p (HsIParamTy x n ty) = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) - go p (HsForAllTy x fvf tvs ty) - = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsForAllTy x tele ty) + = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) go p (HsQualTy x ctxt ty) = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) go p (HsFunTy x ty1 ty2) @@ -347,6 +353,15 @@ reparenType = reparenTypePrec PREC_TOP reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') +reparenHsForAllTelescope :: (XParTy a ~ NoExtField) + => HsForAllTelescope a -> HsForAllTelescope a +reparenHsForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope v@XHsForAllTelescope{} = v + -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b35b54e0..255cbdbc 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -167,7 +167,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do -- See https://github.com/haskell/haddock/issues/469. hsc_env <- getSession let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = homeUnit (hsc_dflags hsc_env) !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts new_rdr_env , let name = gre_name gre diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 786779c6..108e9f66 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -48,7 +48,7 @@ import GHC.Driver.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Unit.State ( lookupModuleInAllPackages, PackageName(..) ) +import GHC.Unit.State import GHC.Data.Bag import GHC.Types.Name.Reader import GHC.Tc.Types @@ -159,7 +159,7 @@ createInterface tm flags modMap instIfaceMap = do !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' let !aliases = - mkAliasMap dflags $ tm_renamed_source tm + mkAliasMap (unitState dflags) $ tm_renamed_source tm modWarn <- liftErrMsg (moduleWarning dflags gre warnings) @@ -197,8 +197,8 @@ createInterface tm flags modMap instIfaceMap = do -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. -mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap dflags mRenamedSource = +mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap state mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> @@ -206,7 +206,7 @@ mkAliasMap dflags mRenamedSource = mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl return $ - (lookupModuleDyn dflags + (lookupModuleDyn state -- TODO: This is supremely dodgy, because in general the -- UnitId isn't going to look anything like the package -- qualifier (even with old versions of GHC, the @@ -265,13 +265,13 @@ unrestrictedModuleImports idecls = -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: - DynFlags -> Maybe Unit -> ModuleName -> Module + UnitState -> Maybe Unit -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName -lookupModuleDyn dflags Nothing mdlName = - case lookupModuleInAllPackages dflags mdlName of +lookupModuleDyn state Nothing mdlName = + case lookupModuleInAllUnits state mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainUnitId mdlName + [] -> Module.mkModule Module.mainUnit mdlName ------------------------------------------------------------------------------- @@ -476,7 +476,7 @@ subordinates instMap decl = case decl of extract_deriv_ty (L l ty) = case ty of -- deriving (forall a. C a {- ^ Doc comment -}) - HsForAllTy{ hst_fvf = ForallInvis + HsForAllTy{ hst_tele = HsForAllInvis{} , hst_body = L _ (HsDocTy _ _ doc) } -> Just (l, doc) -- deriving (C a {- ^ Doc comment -}) @@ -835,7 +835,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in - -- requirementContext (pkgState) + -- requirementContext (unitState) Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> return ([], (noDocForDecl, availNoDocs avail)) @@ -966,8 +966,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule unitId expMod -- Identity module! - unitId = moduleUnit thisMod + m = mkModule (moduleUnit thisMod) expMod -- Identity module! -- Note [1]: ------------ diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 848acb1f..a0c118f8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -223,11 +223,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- mapM renameLTyVarBndr tyvars - ltype' <- renameLType ltype - return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars', hst_body = ltype' }) + HsForAllTy { hst_tele = tele, hst_body = ltype } -> do + tele' <- renameHsForAllTelescope tele + ltype' <- renameLType ltype + return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext @@ -304,6 +304,13 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } +renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) +renameHsForAllTelescope tele = case tele of + HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis x bndrs' + HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis x bndrs' + renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) = do { n' <- rename n diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index cbfea762..e137c258 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -206,12 +206,16 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ _ bndrs _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsForAllTy _ tele _) -> + (Set.empty, Set.union ctx (teleNames tele)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) + + teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs + teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -244,9 +248,9 @@ data RenameEnv name = RenameEnv renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x fvf bndrs lt) = - HsForAllTy x fvf - <$> mapM (located renameBinder) bndrs +renameType (HsForAllTy x tele lt) = + HsForAllTy x + <$> renameForAllTelescope tele <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x @@ -291,11 +295,21 @@ renameLTypes = mapM renameLType renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes +renameForAllTelescope :: HsForAllTelescope GhcRn + -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn) +renameForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x <$> mapM renameLBinder bndrs +renameForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x <$> mapM renameLBinder bndrs + renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname renameBinder (KindedTyVar x fl lname lkind) = KindedTyVar x fl <$> located renameName lname <*> located renameType lkind +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) +renameLBinder = located renameBinder + -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 688e3e71..d0a39322 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -14,10 +14,9 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) -import GHC ( Name ) -import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString ) -import GHC.Driver.Session ( DynFlags ) -import GHC.Unit.State ( lookupUnit, unitPackageIdString ) +import GHC ( Name ) +import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString ) +import GHC.Unit.State ( UnitState, lookupUnit, unitPackageIdString ) import qualified Control.Applicative as A @@ -25,14 +24,14 @@ import qualified Control.Applicative as A data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] -mkModuleTree dflags showPkgs mods = +mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] +mkModuleTree state showPkgs mods = foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap unitPackageIdString - (lookupUnit dflags (moduleUnit mod_)) + (lookupUnit state (moduleUnit mod_)) | otherwise = Nothing fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 011a361d..5c9bf448 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -45,7 +45,7 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit ) +import GHC ( DynFlags, Module, moduleUnit, unitState ) import Haddock.Types import Haddock.Utils import GHC.Unit.State @@ -382,4 +382,4 @@ modulePackageInfo dflags flags (Just modu) = , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupUnit dflags (moduleUnit modu) + pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e8670012..21c7d19b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -695,6 +695,10 @@ type instance XTyLit DocNameI = NoExtField type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX +type instance XHsForAllVis DocNameI = NoExtField +type instance XHsForAllInvis DocNameI = NoExtField +type instance XXHsForAllTelescope DocNameI = NoExtCon + type instance XUserTyVar DocNameI = NoExtField type instance XKindedTyVar DocNameI = NoExtField type instance XXTyVarBndr DocNameI = NoExtCon diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 010bd8bc..d72b9004 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -138,9 +138,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + = L loc (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) diff --git a/html-test/ref/Bug280.html b/html-test/ref/Bug280.html index b6994e7c..04571342 100644 --- a/html-test/ref/Bug280.html +++ b/html-test/ref/Bug280.html @@ -65,9 +65,9 @@ ><p class="src" ><a id="v:x" class="def" >x</a - > :: [<a href="#" title="Data.Char" - >Char</a - >] <a href="#" class="selflink" + > :: <a href="#" title="Data.String" + >String</a + > <a href="#" class="selflink" >#</a ></p ></div diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs index 24e1ccff..e20bcda7 100644 --- a/html-test/src/FunArgs.hs +++ b/html-test/src/FunArgs.hs @@ -22,7 +22,7 @@ h :: forall a b c -> b -- ^ Second argument -> c -- ^ Third argument -> forall d. d -- ^ Result -h = undefined +h _ _ _ = undefined i :: forall a (b :: ()) d. (d ~ '()) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 48218a32..3477d89d 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -1109,7 +1109,7 @@ forall a. [a] -> [a] -> [a] ><span id="" ><span class="annot" ><span class="annottext" - >plugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) + >plugh :: forall a b. Either a a -> Either b b -> Either (a -> b) (b -> a) </span ><a href="#" ><span class="hs-identifier hs-var hs-var hs-var hs-var" diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html index 0c7ddf9e..db6d37b3 100644 --- a/hypsrc-test/ref/src/Literals.html +++ b/hypsrc-test/ref/src/Literals.html @@ -132,7 +132,7 @@ ><span id="num" ><span class="annot" ><span class="annottext" - >num :: a + >num :: forall a. Num a => a </span ><a href="Literals.html#num" ><span class="hs-identifier hs-var hs-var" @@ -285,7 +285,7 @@ forall a. Num a => a -> a -> a ><span id="frac" ><span class="annot" ><span class="annottext" - >frac :: a + >frac :: forall a. Fractional a => a </span ><a href="Literals.html#frac" ><span class="hs-identifier hs-var hs-var" @@ -360,7 +360,7 @@ forall a. Num a => a -> a -> a ><span id="list" ><span class="annot" ><span class="annottext" - >list :: [[[[a]]]] + >list :: forall a. [[[[a]]]] </span ><a href="Literals.html#list" ><span class="hs-identifier hs-var hs-var" diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html index 289684a0..2ce87a6e 100644 --- a/hypsrc-test/ref/src/Operators.html +++ b/hypsrc-test/ref/src/Operators.html @@ -108,7 +108,7 @@ ><span id="%2B%2B%2B" ><span class="annot" ><span class="annottext" - >+++ :: [a] -> [a] -> [a] + >+++ :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%2B%2B%2B" ><span class="hs-operator hs-var hs-var" @@ -273,7 +273,7 @@ forall a. [a] -> [a] -> [a] ><span id="%24%24%24" ><span class="annot" ><span class="annottext" - >$$$ :: [a] -> [a] -> [a] + >$$$ :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%24%24%24" ><span class="hs-operator hs-var hs-var" @@ -406,7 +406,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2A%2A" ><span class="annot" ><span class="annottext" - >*** :: [a] -> [a] -> [a] + >*** :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%2A%2A%2A" ><span class="hs-operator hs-var hs-var" @@ -656,7 +656,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2F%5C%2A" ><span class="annot" ><span class="annottext" - >*/\* :: [[a]] -> [a] -> [a] + >*/\* :: forall a. [[a]] -> [a] -> [a] </span ><a href="Operators.html#%2A%2F%5C%2A" ><span class="hs-operator hs-var hs-var" @@ -828,7 +828,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2A%2F%5C%2A%2A" ><span class="annot" ><span class="annottext" - >**/\** :: [[a]] -> [[a]] -> [[a]] + >**/\** :: forall a. [[a]] -> [[a]] -> [[a]] </span ><a href="Operators.html#%2A%2A%2F%5C%2A%2A" ><span class="hs-operator hs-var hs-var" @@ -1065,7 +1065,7 @@ forall a. [a] -> [a] -> [a] ><span id="%23.%23" ><span class="annot" ><span class="annottext" - >#.# :: a -> b -> c -> (a, b) + >#.# :: forall a b c. a -> b -> c -> (a, b) </span ><a href="Operators.html#%23.%23" ><span class="hs-operator hs-var hs-var" diff --git a/hypsrc-test/ref/src/Polymorphism.html b/hypsrc-test/ref/src/Polymorphism.html index 9f8a1850..1b166aff 100644 --- a/hypsrc-test/ref/src/Polymorphism.html +++ b/hypsrc-test/ref/src/Polymorphism.html @@ -107,7 +107,7 @@ ><span id="foo" ><span class="annot" ><span class="annottext" - >foo :: a -> a -> a + >foo :: forall a. a -> a -> a </span ><a href="Polymorphism.html#foo" ><span class="hs-identifier hs-var hs-var" @@ -205,7 +205,7 @@ forall a. HasCallStack => a ><span id="foo%27" ><span class="annot" ><span class="annottext" - >foo' :: a -> a -> a + >foo' :: forall a. a -> a -> a </span ><a href="Polymorphism.html#foo%27" ><span class="hs-identifier hs-var hs-var" @@ -305,7 +305,7 @@ forall a. HasCallStack => a ><span id="bar" ><span class="annot" ><span class="annottext" - >bar :: a -> b -> (a, b) + >bar :: forall a b. a -> b -> (a, b) </span ><a href="Polymorphism.html#bar" ><span class="hs-identifier hs-var hs-var" @@ -427,7 +427,7 @@ forall a. HasCallStack => a ><span id="bar%27" ><span class="annot" ><span class="annottext" - >bar' :: a -> b -> (a, b) + >bar' :: forall a b. a -> b -> (a, b) </span ><a href="Polymorphism.html#bar%27" ><span class="hs-identifier hs-var hs-var" @@ -557,7 +557,7 @@ forall a. HasCallStack => a ><span id="baz" ><span class="annot" ><span class="annottext" - >baz :: a -> (a -> [a -> a] -> b) -> b + >baz :: forall a b. a -> (a -> [a -> a] -> b) -> b </span ><a href="Polymorphism.html#baz" ><span class="hs-identifier hs-var hs-var" @@ -709,7 +709,7 @@ forall a. HasCallStack => a ><span id="baz%27" ><span class="annot" ><span class="annottext" - >baz' :: a -> (a -> [a -> a] -> b) -> b + >baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b </span ><a href="Polymorphism.html#baz%27" ><span class="hs-identifier hs-var hs-var" @@ -825,7 +825,7 @@ forall a. HasCallStack => a ><span id="quux" ><span class="annot" ><span class="annottext" - >quux :: a -> (forall a. a -> a) -> a + >quux :: forall a. a -> (forall a. a -> a) -> a </span ><a href="Polymorphism.html#quux" ><span class="hs-identifier hs-var hs-var" @@ -994,7 +994,7 @@ forall a. a -> a ><span id="quux%27" ><span class="annot" ><span class="annottext" - >quux' :: a -> (forall a. a -> a) -> a + >quux' :: forall a. a -> (forall a. a -> a) -> a </span ><a href="Polymorphism.html#quux%27" ><span class="hs-identifier hs-var hs-var" @@ -1140,7 +1140,7 @@ forall a. a -> a ><span id="num" ><span class="annot" ><span class="annottext" - >num :: a -> a -> a + >num :: forall a. Num a => a -> a -> a </span ><a href="Polymorphism.html#num" ><span class="hs-identifier hs-var hs-var" @@ -1256,7 +1256,7 @@ forall a. HasCallStack => a ><span id="num%27" ><span class="annot" ><span class="annottext" - >num' :: a -> a -> a + >num' :: forall a. Num a => a -> a -> a </span ><a href="Polymorphism.html#num%27" ><span class="hs-identifier hs-var hs-var" @@ -1402,7 +1402,7 @@ forall a. HasCallStack => a ><span id="eq" ><span class="annot" ><span class="annottext" - >eq :: [a] -> [b] -> (a, b) + >eq :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) </span ><a href="Polymorphism.html#eq" ><span class="hs-identifier hs-var hs-var" @@ -1570,7 +1570,7 @@ forall a. HasCallStack => a ><span id="eq%27" ><span class="annot" ><span class="annottext" - >eq' :: [a] -> [b] -> (a, b) + >eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) </span ><a href="Polymorphism.html#eq%27" ><span class="hs-identifier hs-var hs-var" @@ -1694,7 +1694,7 @@ forall a. HasCallStack => a ><span id="mon" ><span class="annot" ><span class="annottext" - >mon :: (a -> m a) -> m a + >mon :: forall (m :: * -> *) a. Monad m => (a -> m a) -> m a </span ><a href="Polymorphism.html#mon" ><span class="hs-identifier hs-var hs-var" @@ -1840,7 +1840,7 @@ forall a. HasCallStack => a ><span id="mon%27" ><span class="annot" ><span class="annottext" - >mon' :: (a -> m a) -> m a + >mon' :: forall (m :: * -> *) a. Monad m => (a -> m a) -> m a </span ><a href="Polymorphism.html#mon%27" ><span class="hs-identifier hs-var hs-var" @@ -1979,7 +1979,7 @@ forall a. HasCallStack => a ><span id="norf" ><span class="annot" ><span class="annottext" - >norf :: a -> (forall a. Ord a => a -> a) -> a + >norf :: forall a. a -> (forall a. Ord a => a -> a) -> a </span ><a href="Polymorphism.html#norf" ><span class="hs-identifier hs-var hs-var" @@ -2154,7 +2154,7 @@ forall a. HasCallStack => a ><span id="norf%27" ><span class="annot" ><span class="annottext" - >norf' :: a -> (forall a. Ord a => a -> a) -> a + >norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a </span ><a href="Polymorphism.html#norf%27" ><span class="hs-identifier hs-var hs-var" @@ -2272,7 +2272,7 @@ forall a. HasCallStack => a ><span id="plugh" ><span class="annot" ><span class="annottext" - >plugh :: a -> a + >plugh :: forall a. a -> a </span ><a href="Polymorphism.html#plugh" ><span class="hs-identifier hs-var hs-var" @@ -2436,7 +2436,7 @@ forall a. HasCallStack => a ><span id="thud" ><span class="annot" ><span class="annottext" - >thud :: (a -> b) -> a -> (a, b) + >thud :: forall a b. (a -> b) -> a -> (a, b) </span ><a href="Polymorphism.html#thud" ><span class="hs-identifier hs-var hs-var" |