...
 
Commits (3)
......@@ -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
......
......@@ -252,8 +252,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
tyVarArg _ = panic "ppCtor"
resType = apps $ map reL $
......
......@@ -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
......
......@@ -29,6 +29,7 @@ import GHC
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.Outputable ( panic)
......@@ -518,7 +519,7 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX]
ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]
ppTyVars = map (ppSymName . getName . hsLTyVarNameI)
......@@ -897,7 +898,8 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
-- * Type applications
--------------------------------------------------------------------------------
ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>
Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX
ppAppDocNameTyVarBndrs unicode n vs =
ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
where
......@@ -1007,10 +1009,21 @@ ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
ppLParendType unicode ki
ppLHsTypeArg _ (HsArgPar _) = text ""
ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
class RenderableBndrFlag flag where
ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX
instance RenderableBndrFlag () where
ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name
ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) =
parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
instance RenderableBndrFlag Specificity where
ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name
ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name
ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) =
parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) =
braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
......
......@@ -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]
......
......@@ -34,6 +34,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
import GHC.Core.Type ( Specificity(..) )
import GHC.Types.Basic (PromotionFlag(..), isPromoted)
import GHC hiding (LexicalFixity(..))
import GHC.Exts
......@@ -188,10 +189,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag
ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag
-> Html
ppForAll tvs unicode qual fvf =
case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
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 $
......@@ -226,7 +227,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
-- | Pretty-print type variables.
ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
ppTyVars :: RenderableBndrFlag flag =>
Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html]
ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
......@@ -407,7 +409,8 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
-- * Type applications
--------------------------------------------------------------------------------
ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>
Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
where
......@@ -1107,12 +1110,28 @@ ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual
ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
ppLParendType unicode qual emptyCtxts ki
ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
class RenderableBndrFlag flag where
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html
instance RenderableBndrFlag () where
ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) =
ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
instance RenderableBndrFlag Specificity where
ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) =
ppDocName qual Raw False name
ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) =
braces $ ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =
braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
......@@ -1146,7 +1165,8 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html
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
......
......@@ -47,6 +47,7 @@ import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import Haddock.Types
import Haddock.Interface.Specialize
......@@ -85,6 +86,15 @@ tyThingToLHsDecl prr t = case t of
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField
(L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
cvt (XTyVarBndr nec) = noExtCon nec
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = mapLoc cvt
extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl fd rhs =
TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
......@@ -210,8 +220,8 @@ synifyTyCon prr _coax tc
where
-- tyConTyVars doesn't work on fun/prim, but we can make them up:
mk_hs_tv realKind fakeTyVar
| isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar))
| otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
| isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))
| otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
conKind = defaultType prr (tyConKind tc)
tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
......@@ -335,7 +345,7 @@ synifyFamilyResultSig Nothing kind
| isLiftedTypeKind kind = noLoc $ NoSig noExtField
| otherwise = noLoc $ KindSig noExtField (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
......@@ -352,7 +362,7 @@ synifyDataCon use_gadt_syntax dc =
name = synifyName dc
-- con_qvars means a different thing depending on gadt-syntax
(_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
user_tvs = dataConUserTyVars dc -- Used for GADT data constructors
user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
......@@ -382,10 +392,10 @@ synifyDataCon use_gadt_syntax dc =
\hat ->
if use_gadt_syntax
then return $ noLoc $
ConDeclGADT { con_g_ext = noExtField
ConDeclGADT { con_g_ext = []
, con_names = [name]
, con_forall = noLoc $ not $ null user_tvs
, con_qvars = synifyTyVars user_tvs
, con_forall = noLoc $ not $ null user_tvbndrs
, con_qvars = map synifyInvisTyVar user_tvbndrs
, con_mb_cxt = ctx
, con_args = hat
, con_res_ty = synifyType WithinType [] res_ty
......@@ -394,7 +404,7 @@ synifyDataCon use_gadt_syntax dc =
ConDeclH98 { con_ext = noExtField
, con_name = name
, con_forall = noLoc False
, con_ex_tvs = map synifyTyVar ex_tvs
, con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs
, con_mb_cxt = ctx
, con_args = hat
, con_doc = Nothing }
......@@ -439,20 +449,27 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs = HsQTvs { hsq_ext = []
, hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn
synifyTyVar = synifyTyVar' emptyVarSet
synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
synifyInvisTyVar = synifyInvisTyVar' emptyVarSet
-- | Like 'synifyTyVar', 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' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn
synifyTyVar' no_kinds tv
| isLiftedTypeKind kind || tv `elemVarSet` no_kinds
= noLoc (UserTyVar noExtField (noLoc name))
| otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
= noLoc (UserTyVar noExtField () (noLoc name))
| otherwise = noLoc (KindedTyVar noExtField () (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.
......@@ -631,6 +648,7 @@ synifyForAllType
-> LHsType GhcRn
synifyForAllType s argf vs ty =
let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
inv_tvs = map to_invis_bndr tvs
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
, hst_body = synifyType WithinType (tvs' ++ vs) tau }
......@@ -640,7 +658,7 @@ synifyForAllType s argf vs ty =
, hst_xforall = noExtField
, hst_body = noLoc sPhi }
sTvs = map synifyTyVar tvs
sTvs = map synifyInvisTyVar inv_tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
......@@ -654,8 +672,12 @@ synifyForAllType s argf vs ty =
| not (null tvs) -> noLoc sTy
| otherwise -> noLoc sPhi
ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
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
-- | Put a forall in if there are any type variables which require
-- explicit kind annotations or if the inferred type variable order
......@@ -663,14 +685,14 @@ synifyForAllType s argf vs ty =
implicitForAll
:: [TyCon] -- ^ type constructors that determine their args kinds
-> [TyVar] -- ^ free variables in the type to convert
-> [TyVar] -- ^ type variable binders in the forall
-> [InvisTVBinder] -- ^ type variable binders in the forall
-> ThetaType -- ^ constraints right after the forall
-> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type
-> Type -- ^ inner type
-> LHsType GhcRn
implicitForAll tycons vs tvs ctx synInner tau
| any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy
| tvs' /= tvs = noLoc sTy
| tvs' /= (binderVars tvs) = noLoc sTy
| otherwise = noLoc sPhi
where
sRho = synInner (tvs' ++ vs) tau
......@@ -685,7 +707,7 @@ implicitForAll tycons vs tvs ctx synInner tau
, hst_body = noLoc sPhi }
no_kinds_needed = noKindTyVars tycons tau
sTvs = map (synifyTyVar' no_kinds_needed) tvs
sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
......@@ -729,7 +751,7 @@ noKindTyVars _ _ = emptyVarSet
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
ts = maybeToList (tyConAppTyCon_maybe res_ty)
-- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
......@@ -831,18 +853,18 @@ invariant didn't hold.
-- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
--
-- See Note [Invariant: Never expand type synonyms]
tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type)
tcSplitSigmaTySameVisPreserveSynonyms argf ty =
case tcSplitForAllTysSameVisPreserveSynonyms argf ty of
(tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of
(theta, tau) -> (tvs, theta, tau)
-- | See Note [Invariant: Never expand type synonyms]
tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)
tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type)
tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
where
split _ (ForAllTy (Bndr tv argf) ty') tvs
| argf `sameVis` supplied_argf = split ty' ty' (tv:tvs)
split _ (ForAllTy tvbndr@(Bndr _ argf) ty') tvs
| argf `sameVis` supplied_argf = split ty' ty' (tvbndr:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]
......
......@@ -161,11 +161,11 @@ nubByName f ns = go emptyNameSet ns
-- These functions are duplicated from the GHC API, as they must be
-- instantiated at DocNameI instead of (GhcPass _).
hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName
hsTyVarNameI (UserTyVar _ (L _ n)) = n
hsTyVarNameI (KindedTyVar _ (L _ n) _) = n
hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (UserTyVar _ _ (L _ n)) = n
hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName
hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
hsLTyVarNameI = hsTyVarNameI . unLoc
getConNamesI :: ConDecl DocNameI -> [Located DocName]
......@@ -189,7 +189,7 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
, con_res_ty = res_ty })
| has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
, hst_xforall = noExtField
, hst_bndrs = hsQTvExplicit qtvs
, hst_bndrs = qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
......@@ -244,7 +244,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
, con_res_ty = res_ty })
| has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis
, hst_xforall = noExtField
, hst_bndrs = hsQTvExplicit qtvs
, hst_bndrs = qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
......@@ -348,9 +348,9 @@ reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType = fmap reparenType
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a
reparenTyVar (UserTyVar x n) = UserTyVar x n
reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind)
reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
......
......@@ -164,7 +164,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
......
......@@ -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
-------------------------------------------------------------------------------
......@@ -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]:
------------
......
......@@ -304,14 +304,14 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
; return (HsQTvs { hsq_ext = noExtField
, hsq_explicit = tvs' }) }
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar x (L l n)))
renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))
= do { n' <- rename n
; return (L loc (UserTyVar x (L l n'))) }
renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
; return (L loc (UserTyVar x fl (L l n'))) }
renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
; return (L loc (KindedTyVar x (L lv n') kind')) }
; return (L loc (KindedTyVar x fl (L lv n') kind')) }
renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
......@@ -475,7 +475,7 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
, con_res_ty = res_ty
, con_doc = mbldoc }) = do
lnames' <- mapM renameL lnames
ltyvars' <- renameLHsQTyVars ltyvars
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details
res_ty' <- renameLType res_ty
......
......@@ -60,8 +60,8 @@ specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
bname (UserTyVar _ (L _ name)) = name
bname (KindedTyVar _ (L _ name) _) = name
bname (UserTyVar _ _ (L _ name)) = name
bname (KindedTyVar _ _ (L _ name) _) = name
bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
......@@ -291,10 +291,10 @@ renameLTypes = mapM renameLType
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
renameBinder (KindedTyVar x lname lkind) =
KindedTyVar x <$> located renameName lname <*> located renameType lkind
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
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
......@@ -348,7 +348,7 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr name -> IdP name
tyVarName (UserTyVar _ name) = unLoc name
tyVarName (KindedTyVar _ (L _ name) _) = name
tyVarName :: HsTyVarBndr flag name -> IdP name
tyVarName (UserTyVar _ _ name) = unLoc name
tyVarName (KindedTyVar _ _ (L _ name) _) = name
tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
......@@ -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
......
......@@ -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)
......@@ -380,12 +380,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
, pfdKindSig = fdResultSig
}
where
mkType :: HsTyVarBndr (GhcPass p) -> HsType (GhcPass p)
mkType (KindedTyVar _ (L loc name) lkind) =
mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
mkType (KindedTyVar _ _ (L loc name) lkind) =
HsKindSig noExtField tvar lkind
where
tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))
mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name
mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name
-- | An instance head that may have documentation and a source location.
......
......@@ -13,7 +13,7 @@ $(do
let methodN = mkName "foo"
methodTy <- [t| $(varT a) -> $(varT a) |]
let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy]
let cla = ClassD [] classN [PlainTV a ()] [] [SigD methodN methodTy]
-- Note that we are /reusing/ the same type variable 'a' as in the class
instanceHead <- [t| $(conT classN) (Bar $(varT a)) |]
......