aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal8
-rw-r--r--haddock-api/resources/html/Ocean.std-theme/ocean.css13
-rw-r--r--haddock-api/src/Haddock.hs13
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs31
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs35
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Convert.hs43
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/Utils.hs7
13 files changed, 108 insertions, 69 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index e1e7480f..50ebca0b 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -49,10 +49,10 @@ library
, xhtml >= 3000.2 && < 3000.3
, Cabal >= 1.10
, ghc-boot
- , ghc >= 7.10 && < 7.12
+ , ghc >= 8.0 && < 8.2
, ghc-paths
- , haddock-library == 1.2.*
+ , haddock-library == 1.4.*
hs-source-dirs:
src
@@ -115,9 +115,9 @@ test-suite spec
Haddock.Backends.Hyperlinker.ParserSpec
build-depends:
- base >= 4.3 && < 4.9
+ base
, containers
- , ghc >= 7.10 && < 7.12
+ , ghc
, hspec
, QuickCheck == 2.*
diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index 139335ac..fcf23810 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -381,21 +381,16 @@ div#style-menu-holder {
#interface h5 + div.top {
margin-top: 1em;
}
-#interface p.src .link {
+#interface .src .selflink,
+#interface .src .link {
float: right;
color: #919191;
- border-left: 1px solid #919191;
background: #f0f0f0;
padding: 0 0.5em 0.2em;
- margin: 0 -0.5em 0 0.5em;
+ margin: 0 -0.5em 0 0;
}
-
-#interface td.src .link {
- float: right;
- color: #919191;
+#interface .src .selflink {
border-left: 1px solid #919191;
- background: #f0f0f0;
- padding: 0 0.5em 0.2em;
margin: 0 -0.5em 0 0.5em;
}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 72a6cc92..5e8f4a4a 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -248,6 +248,9 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
opt_latex_style = optLaTeXStyle flags
opt_source_css = optSourceCssFile flags
opt_mathjax = optMathjax flags
+ dflags'
+ | unicode = gopt_set dflags Opt_PrintUnicodeSyntax
+ | otherwise = dflags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -287,24 +290,24 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
libDir <- getHaddockLibDir flags
- prologue <- getPrologue dflags flags
+ prologue <- getPrologue dflags' flags
themes <- getThemes libDir flags >>= either bye return
when (Flag_GenIndex `elem` flags) $ do
ppHtmlIndex odir title pkgStr
- themes opt_contents_url sourceUrls' opt_wiki_urls
+ themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
allVisibleIfaces pretty
copyHtmlBits odir libDir themes
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents dflags odir title pkgStr
+ ppHtmlContents dflags' odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
allVisibleIfaces True prologue pretty
(makeContentsQual qual)
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
- ppHtml dflags title pkgStr visibleIfaces odir
+ ppHtml dflags' title pkgStr visibleIfaces odir
prologue
themes opt_mathjax sourceUrls' opt_wiki_urls
opt_contents_url opt_index_url unicode qual
@@ -326,7 +329,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
Just (PackageName pkgNameFS, pkgVer) ->
let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
| otherwise = unpackFS pkgNameFS
- in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue)
+ in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
visibleIfaces odir
when (Flag_LaTeX `elem` flags) $ do
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index e8baae88..be17cb8b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -117,7 +117,7 @@ decls (group, _, _, _) = concatMap ($ group)
]
where
typ (GHC.L _ t) = case t of
- GHC.DataDecl name _ _ _ -> pure . decl $ name
+ GHC.DataDecl { tcdLName = name } -> pure . decl $ name
GHC.SynDecl name _ _ _ -> pure . decl $ name
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b7be7ffb..81a23a1b 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -641,7 +641,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
ppOcc = case occ of
[one] -> ppBinder one
_ -> cat (punctuate comma (map ppBinder occ))
- tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
context = unLoc (fromMaybe (noLoc []) (con_cxt con))
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index ebd53370..f7284062 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -90,11 +90,11 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue
when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
- themes maybe_contents_url maybe_source_url maybe_wiki_url
+ themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces) debug
mapM_ (ppHtmlModule odir doctitle themes
- maybe_source_url maybe_wiki_url
+ maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
@@ -269,7 +269,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
-- XXX: think of a better place for this?
- ppHtmlContentsFrame odir doctitle themes ifaces debug
+ ppHtmlContentsFrame odir doctitle themes mathjax_url ifaces debug
ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
@@ -342,12 +342,12 @@ flatModuleTree ifaces =
<< toHtml txt
-ppHtmlContentsFrame :: FilePath -> String -> Themes
+ppHtmlContentsFrame :: FilePath -> String -> Themes -> Maybe String
-> [InstalledInterface] -> Bool -> IO ()
-ppHtmlContentsFrame odir doctitle themes ifaces debug = do
+ppHtmlContentsFrame odir doctitle themes maybe_mathjax_url ifaces debug = do
let mods = flatModuleTree ifaces
html =
- headHtml doctitle Nothing themes Nothing +++
+ headHtml doctitle Nothing themes maybe_mathjax_url +++
miniBody << divModuleList <<
(sectionName << "Modules" +++
ulist << [ li ! [theclass "module"] << m | m <- mods ])
@@ -365,13 +365,14 @@ ppHtmlIndex :: FilePath
-> Maybe String
-> Themes
-> Maybe String
+ -> Maybe String
-> SourceURLs
-> WikiURLs
-> [InstalledInterface]
-> Bool
-> IO ()
ppHtmlIndex odir doctitle _maybe_package themes
- maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
+ maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
let html = indexPage split_indices Nothing
(if split_indices then [] else index)
@@ -387,7 +388,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
where
indexPage showLetters ch items =
- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes Nothing +++
+ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
maybe_contents_url Nothing << [
@@ -487,11 +488,11 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
- -> SourceURLs -> WikiURLs
+ -> Maybe String -> SourceURLs -> WikiURLs
-> Maybe String -> Maybe String -> Bool -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
- maybe_source_url maybe_wiki_url
+ maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug iface = do
let
mdl = ifaceMod iface
@@ -499,7 +500,7 @@ ppHtmlModule odir doctitle themes
mdl_str = moduleString mdl
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes Nothing +++
+ headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
@@ -509,14 +510,14 @@ ppHtmlModule odir doctitle themes
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
+ ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Interface -> Bool -> Qualification -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
+ -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
let mdl = ifaceMod iface
html =
- headHtml (moduleString mdl) Nothing themes Nothing +++
+ headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++
miniBody <<
(divModuleHeader << sectionName << moduleString mdl +++
miniSynopsis mdl iface unicode qual)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 66bb21da..fab6bf8d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -171,6 +171,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
rightEdge = thespan ! [theclass "rightedge"] << noHtml
+-- | Pretty-print type variables.
ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
@@ -208,7 +209,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
+ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html
ppTypeSig summary nms pp_ty unicode =
concatHtml htmlNames <+> dcolon unicode <+> pp_ty
where
@@ -248,8 +249,8 @@ ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
-> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdResultSig = L _ result
- , fdInjectivityAnn = injectivity })
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
unicode qual =
(case info of
OpenTypeFamily
@@ -262,12 +263,17 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
-> keyword "type family"
) <+>
- ppFamDeclBinderWithVars summary d <+>
+ ppFamDeclBinderWithVars summary unicode qual d <+>
ppResultSig result unicode qual <+>
(case injectivity of
Nothing -> noHtml
Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
+ ) <+>
+
+ (case info of
+ ClosedTypeFamily _ -> keyword "where ..."
+ _ -> mempty
)
ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
@@ -346,9 +352,9 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
--------------------------------------------------------------------------------
-- | Print a type family and its variables
-ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
-ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
- ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
+ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+ ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs)
-- | Print a newtype / data binder and its variables
ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
@@ -359,15 +365,22 @@ ppDataBinderWithVars summ decl =
-- * Type applications
--------------------------------------------------------------------------------
+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html
+ppAppDocNameTyVarBndrs summ unicode qual n vs =
+ ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)
+ where
+ ppDN notation = ppBinderFixity notation summ . nameOccName . getName
+ ppBinderFixity Infix = ppBinderInfix
+ ppBinderFixity _ = ppBinder
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+-- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types)
ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
-> Unicode -> Qualification -> Html
ppAppNameTypes n ks ts unicode qual =
ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
--- | Print an application of a DocName and a list of Names
+-- | Print an application of a 'DocName' and a list of 'Names'
ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
ppAppDocNameNames summ n ns =
ppTypeApp n [] ns ppDN ppTyName
@@ -769,7 +782,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
[one] -> ppBinderInfix summary one
_ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
- ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)
+ ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)
tyVars = tyvarNames ltvs
lcontext = fromMaybe (noLoc []) (con_cxt con)
context = unLoc lcontext
@@ -839,7 +852,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
[one] -> ppBinderInfix False one
_ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
- tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+ tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
context = unLoc (fromMaybe (noLoc []) (con_cxt con))
forall_ = False
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 7fab3fea..41457f72 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -44,12 +44,13 @@ import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
-import Haddock.Utils (makeAnchorId)
+import Haddock.Utils (makeAnchorId, nameAnchorId)
import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, p, quote )
import FastString ( unpackFS )
import GHC
+import Name (nameOccName)
--------------------------------------------------------------------------------
-- * Sections of the document
@@ -264,9 +265,11 @@ topDeclElem lnks loc splice names html =
-- | Adds a source and wiki link at the right hand side of the box.
-- Name must be documented, otherwise we wouldn't get here.
links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html
-links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =
- (srcLink <+> wikiLink)
- where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =
+ srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")
+ where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))
+
+ srcLink = let nameUrl = Map.lookup origPkg sourceMap
lineUrl = Map.lookup origPkg lineMap
mUrl | splice = lineUrl
-- Use the lineUrl as a backup
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index c69710d1..5492178b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -120,11 +120,11 @@ ppBinderWith :: Notation -> Bool -> OccName -> Html
-- the documentation or is the actual definition; in the latter case, we also
-- set the 'id' and 'class' attributes.
ppBinderWith notation isRef n =
- linkedAnchor name ! attributes << ppBinder' notation n
+ makeAnchor << ppBinder' notation n
where
name = nameAnchorId n
- attributes | isRef = []
- | otherwise = [identifier name, theclass "def"]
+ makeAnchor | isRef = linkedAnchor name
+ | otherwise = namedAnchor name ! [theclass "def"]
ppBinder' :: Notation -> OccName -> Html
ppBinder' notation n = wrapInfix notation n $ ppOccName n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 98ff4007..1d49807d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -195,7 +195,7 @@ dot = toHtml "."
-- | Generate a named anchor
namedAnchor :: String -> Html -> Html
-namedAnchor n = anchor ! [XHtml.name n]
+namedAnchor n = anchor ! [XHtml.identifier n]
linkedAnchor :: String -> Html -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 96a1c01c..71a81190 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -26,6 +26,7 @@ import DataCon
import FamInstEnv
import HsSyn
import Name
+import NameSet ( emptyNameSet )
import RdrName ( mkVarUnqual )
import PatSyn
import SrcLoc ( Located, noLoc, unLoc )
@@ -34,9 +35,9 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )
-import TysWiredIn ( listTyConName, starKindTyConName )
+import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
import PrelNames ( hasKey, eqTyConKey, ipClassKey
- , tYPETyConKey, liftedDataConKey, unliftedDataConKey )
+ , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )
import Unique ( getUnique )
import Util ( filterByList, filterOut )
import Var
@@ -100,8 +101,7 @@ tyThingToLHsDecl t = case t of
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
- (patSynType ps))
+ allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -144,7 +144,7 @@ synifyTyCon _coax tc
in HsQTvs { hsq_implicit = [] -- No kind polymorphism
, hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
alphaTyVars --a, b, c... which are unfortunately all kind *
- }
+ , hsq_dependent = emptyNameSet }
, tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
@@ -154,6 +154,7 @@ synifyTyCon _coax tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = Nothing }
+ , tcdDataCusk = False
, tcdFVs = placeHolderNamesTc }
synifyTyCon _coax tc
@@ -180,12 +181,11 @@ synifyTyCon _coax tc
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConTyVars tc)
, fdResultSig =
- synifyFamilyResultSig resultVar tyConResKind
+ synifyFamilyResultSig resultVar (tyConResKind tc)
, fdInjectivityAnn =
synifyInjectivityAnn resultVar (tyConTyVars tc)
(familyTyConInjectivityInfo tc)
}
- tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc))
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
@@ -234,7 +234,7 @@ synifyTyCon coax tc
in case lefts consRaw of
[] -> return $
DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
- , tcdFVs = placeHolderNamesTc }
+ , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
@@ -323,7 +323,8 @@ synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> LHsQTyVars Name
synifyTyVars ktvs = HsQTvs { hsq_implicit = []
- , hsq_explicit = map synifyTyVar ktvs }
+ , hsq_explicit = map synifyTyVar ktvs
+ , hsq_dependent = emptyNameSet }
synifyTyVar :: TyVar -> LHsTyVarBndr Name
synifyTyVar tv
@@ -358,17 +359,21 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
-- Ditto (see synifySigType)
synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+synifyPatSynSigType :: PatSyn -> LHsSigType Name
+-- Ditto (see synifySigType)
+synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
+
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
-- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
- , lev `hasKey` liftedDataConKey
+ , lev `hasKey` ptrRepLiftedDataConKey
= noLoc (HsTyVar (noLoc starKindTyConName))
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
- , lev `hasKey` unliftedDataConKey
+ , lev `hasKey` ptrRepUnliftedDataConKey
= noLoc (HsTyVar (noLoc unliftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
@@ -419,6 +424,22 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
synifyType s (CastTy t _) = synifyType s t
synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
+synifyPatSynType :: PatSyn -> LHsType Name
+synifyPatSynType ps = let
+ (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+ req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]
+ -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
+ -- i.e., an explicit empty context, which is what we need. This is not
+ -- possible by taking theta = [], as that will print no context at all
+ | otherwise = req_theta
+ sForAll [] s = s
+ sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_body = noLoc s }
+ sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
+ , hst_body = noLoc s }
+ sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
+ in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
+
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy mempty n
synifyTyLit (StrTyLit s) = HsStrTy mempty s
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 0f97ee3b..3054e2f9 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -270,7 +270,7 @@ renameType t = case t of
renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) }
+ ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -350,7 +350,7 @@ renameTyClD d = case d of
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames })
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 325dd710..58a7ef90 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -64,6 +64,7 @@ import Haddock.GhcUtils
import GHC
import Name
+import NameSet ( emptyNameSet )
import HsTypes (selectorFieldOcc)
import Control.Monad ( liftM )
@@ -201,7 +202,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
c' = ConDeclH98
{ con_name = head (con_names c)
, con_qvars = Just $ HsQTvs { hsq_implicit = mempty
- , hsq_explicit = tvs }
+ , hsq_explicit = tvs
+ , hsq_dependent = emptyNameSet }
, con_cxt = Just cxt
, con_details = details
, con_doc = con_doc c
@@ -226,7 +228,8 @@ emptyHsQTvs :: LHsQTyVars Name
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
- , hsq_explicit = [] }
+ , hsq_explicit = []
+ , hsq_dependent = error "haddock:emptyHsQTvs" }
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 16:29:15 +0000