aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs135
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs222
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Convert.hs35
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs8
-rw-r--r--haddock-api/src/Haddock/Options.hs5
9 files changed, 271 insertions, 170 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dbfba0f4..8c0ae705 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -161,16 +161,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ -- bypass the interface version check
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
unless (Flag_NoWarnings `elem` flags) $ do
hypSrcWarnings flags
forM_ (warnings args) $ \warning -> do
hPutStrLn stderr warning
+ when noChecks $
+ hPutStrLn stderr noCheckWarning
ghc flags' $ do
dflags <- getDynFlags
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+ mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
@@ -192,7 +197,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep dflags flags sinceQual qual packages []
@@ -203,6 +208,10 @@ warnings = map format . filter (isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+-- | Create a warning about bypassing the interface version check
+noCheckWarning :: String
+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
+ "Haddock to crash when reading Haddock interface files."
withGhc :: [Flag] -> Ghc a -> IO a
withGhc flags action = do
@@ -220,7 +229,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map snd packages
@@ -404,13 +414,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
readInterfaceFiles :: MonadIO m
=> NameCacheAccessor m
-> [(DocPaths, FilePath)]
+ -> Bool
-> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file >>= \case
+ readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index acb2c892..f8494242 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =
-- A Haskell line comment
then case span (/= '\n') str' of
(str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)
- (_, _) -> (str, "")
+ (_, _) -> (str, "")
-- An actual Haskell token
else let (str'', rest) = spanToNewline 0 str'
@@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
go :: (RealSrcLoc, [T.Token], Bool)
-- ^ current position, tokens accumulated, currently in pragma (or not)
-
+
-> (Located L.Token, String)
-- ^ next token, its content
-
+
-> (RealSrcLoc, [T.Token], Bool)
-- ^ new position, new tokens accumulated, currently in pragma (or not)
@@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
)
where
(next_pos, white) = mkWhitespace pos l
-
+
classifiedTok = [ Token (classify' tok) raw rss
| RealSrcSpan rss <- [l]
, not (null raw)
]
-
+
classify' | in_prag = const TkPragma
| otherwise = classify
@@ -378,6 +378,7 @@ classify tok =
ITLarrowtail {} -> TkGlyph
ITRarrowtail {} -> TkGlyph
+ ITcomment_line_prag -> TkUnknown
ITunknown {} -> TkUnknown
ITeof -> TkUnknown
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4a3e9d03..0c7747bd 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -12,10 +12,9 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.LaTeX (
- ppLaTeX
+ ppLaTeX,
) where
-
import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
@@ -285,7 +284,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode
TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
@@ -303,12 +302,6 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
unicode = False
-ppTyFam :: Bool -> Documentation DocName ->
- TyClDecl DocNameI -> Bool -> LaTeX
-ppTyFam _ _ _ _ =
- error "type family declarations are currently not supported by --latex"
-
-
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
ppFunSig doc [name] (hsSigType typ) unicode
@@ -317,6 +310,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-------------------------------------------------------------------------------
+-- * Type families
+-------------------------------------------------------------------------------
+
+-- | Pretty-print a data\/type family declaration
+ppFamDecl :: Documentation DocName -- ^ this decl's docs
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> TyClDecl DocNameI -- ^ family to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamDecl doc instances decl unicode =
+ declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit)
+ (if null body then Nothing else Just (vcat body))
+ $$ instancesBit
+ where
+ body = catMaybes [familyEqns, documentationToLaTeX doc]
+
+ whereBit = case fdInfo (tcdFam decl) of
+ ClosedTypeFamily _ -> keyword "where"
+ _ -> empty
+
+ familyEqns
+ | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
+ = Just (text "\\haddockbeginargs" $$
+ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
+ text "\\end{tabulary}\\par")
+ | otherwise = Nothing
+
+ -- Individual equations of a closed type family
+ ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
+ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts } })
+ = hsep [ ppAppNameTypes n (map unLoc ts) unicode
+ , equals
+ , ppType unicode (unLoc rhs)
+ ]
+ ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
+
+ instancesBit = ppDocInstances unicode instances
+
+-- | Print the LHS of a type\/data family declaration.
+ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader"
+ppFamHeader (FamilyDecl { fdLName = L _ name
+ , fdTyVars = tvs
+ , fdInfo = info
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
+ unicode =
+ leader <+> keyword "family" <+> famName <+> famSig <+> injAnn
+ where
+ leader = case info of
+ OpenTypeFamily -> keyword "type"
+ ClosedTypeFamily _ -> keyword "type"
+ DataFamily -> keyword "data"
+
+ famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
+
+ famSig = case result of
+ NoSig _ -> empty
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr
+ XFamilyResultSig _ -> panic "haddock:ppFamHeader"
+
+ injAnn = case injectivity of
+ Nothing -> empty
+ Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")
+ : ppLDocName lhs
+ : arrow unicode
+ : map ppLDocName rhs)
+
+
+
+-------------------------------------------------------------------------------
-- * Type Synonyms
-------------------------------------------------------------------------------
@@ -538,12 +608,14 @@ ppClassDecl instances doc subdocs
| otherwise = error "LaTeX.ppClassDecl"
methodTable =
- text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
+ text "\\haddockpremethods{}" <> emph (text "Methods") $$
+ vcat [ ppFunSig doc names (hsSigWcType typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
- , name <- map unLoc lnames
- , let doc = lookupAnySubdoc name subdocs
- ]
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
instancesBit = ppDocInstances unicode instances
@@ -573,14 +645,13 @@ ppDocInstance unicode (instHead, doc, _, _) =
ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
-ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
-
-
-ppInstHead :: Bool -> InstHead DocNameI -> LaTeX
-ppInstHead unicode (InstHead {..}) = case ihdInstType of
- ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
- TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
- DataInst _ -> error "data instances not supported by --latex yet"
+ppInstDecl unicode (InstHead {..}) = case ihdInstType of
+ ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ
+ TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs
+ DataInst dd ->
+ let nd = dd_ND (tcdDataDefn dd)
+ pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
+ in pref <+> keyword "instance" <+> typ
where
typ = ppAppNameTypes ihdClsName ihdTypes unicode
tibody = maybe empty (\t -> equals <+> ppType unicode t)
@@ -613,7 +684,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
+ body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]
(whereBit, leaders)
| null cons
@@ -823,6 +894,12 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
-- * Type applications
--------------------------------------------------------------------------------
+ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
+ppAppDocNameTyVarBndrs unicode n vs =
+ ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
+ where
+ ppDN = ppBinder . nameOccName . getName
+
-- | Print an application of a DocName to its list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
@@ -897,7 +974,7 @@ tupleParens _ = parenList
sumParens :: [LaTeX] -> LaTeX
-sumParens = ubxparens . hsep . punctuate (text " | ")
+sumParens = ubxparens . hsep . punctuate (text " |")
-------------------------------------------------------------------------------
@@ -917,6 +994,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
+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
+ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
+
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
@@ -973,7 +1056,7 @@ ppr_mono_ty (HsParTy _ ty) unicode
ppr_mono_ty (HsDocTy _ ty _) unicode
= ppr_mono_lty ty unicode
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_'
+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_"
ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
@@ -1252,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma
ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
+ubxparens h = text "(#" <+> h <+> text "#)"
nl :: LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index cc271fef..12e65716 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -15,9 +15,7 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Decl (
ppDecl,
-
- ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,
- tyvarNames
+ ppOrphanInstances,
) where
import Haddock.Backends.Xhtml.DocMarkup
@@ -56,7 +54,7 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
- TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+ TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual
TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
@@ -67,7 +65,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -222,9 +220,6 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
-tyvarNames :: LHsQTyVars DocNameI -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
-
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
@@ -283,111 +278,111 @@ ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
--------------------------------------------------------------------------------
-ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html
-ppFamilyInfo assoc OpenTypeFamily
- | assoc = keyword "type"
- | otherwise = keyword "type family"
-ppFamilyInfo assoc DataFamily
- | assoc = keyword "data"
- | otherwise = keyword "data family"
-ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
-
-
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI
- -> Unicode -> Qualification -> Html
-ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdResultSig = L _ result
- , fdInjectivityAnn = injectivity })
- unicode qual =
- (case info of
- OpenTypeFamily
- | associated -> keyword "type"
- | otherwise -> keyword "type family"
- DataFamily
- | associated -> keyword "data"
- | otherwise -> keyword "data family"
- ClosedTypeFamily _
- -> keyword "type family"
- ) <+>
-
- 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
- )
-ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
-
-ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
-ppResultSig result unicode qual = case result of
- NoSig _ -> noHtml
- KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- XFamilyResultSig _ -> panic "haddock:ppResultSig"
-
-ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
- -> Html
-ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
- ppFamilyInfo True pfdInfo <+>
- ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
- ppResultSig (unLoc pfdKindSig) unicode qual
-
-ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html
-ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
- char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>
- hsep (map (ppLDocName qual Raw) rhs)
-
-
-ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
- [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->
- Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl splice unicode
- pkg qual
-
- | summary = ppTyFamHeader True associated decl unicode qual
+-- | Print a data\/type family declaration
+ppFamDecl :: Bool -- ^ is a summary
+ -> Bool -- ^ is an associated type
+ -> LinksInfo
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> [(DocName, Fixity)] -- ^ relevant fixities
+ -> SrcSpan
+ -> Documentation DocName -- ^ this decl's documentation
+ -> FamilyDecl DocNameI -- ^ this decl
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual
+ | summary = ppFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit
where
docname = unLoc $ fdLName decl
header_ = topDeclElem links loc splice [docname] $
- ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
+ ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
instancesBit
| FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
, not summary
- = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
+ = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns
| otherwise
= ppInstances links (OriginFamily docname) instances splice unicode pkg qual
-- Individual equation of a closed type family
- ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
- ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
- , feqn_pats = ts } })
- = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+ ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl
+ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts } })
+ = ( ppAppNameTypes n (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
- , Nothing, [] )
- ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
- ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
-
+ , Nothing
+ , []
+ )
+ ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
-ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
- -> PseudoFamilyDecl DocNameI
- -> Html
-ppPseudoFamilyDecl links splice unicode qual
- decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
- wrapper $ ppPseudoFamilyHeader unicode qual decl
+-- | Print a pseudo family declaration
+ppPseudoFamDecl :: LinksInfo -> Splice
+ -> PseudoFamilyDecl DocNameI -- ^ this decl
+ -> Unicode -> Qualification -> Html
+ppPseudoFamDecl links splice
+ (PseudoFamilyDecl { pfdInfo = info
+ , pfdKindSig = L _ kindSig
+ , pfdTyVars = tvs
+ , pfdLName = L loc name })
+ unicode qual =
+ topDeclElem links loc splice [name] leader
+ where
+ leader = hsep [ ppFamilyLeader True info
+ , ppAppNameTypes name (map unLoc tvs) unicode qual
+ , ppResultSig kindSig unicode qual
+ ]
+
+-- | Print the LHS of a type\/data family declaration
+ppFamHeader :: Bool -- ^ is a summary
+ -> Bool -- ^ is an associated type
+ -> FamilyDecl DocNameI -- ^ family declaration
+ -> Unicode -> Qualification -> Html
+ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"
+ppFamHeader summary associated (FamilyDecl { fdInfo = info
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity
+ , fdLName = L _ name
+ , fdTyVars = tvs })
+ unicode qual =
+ hsep [ ppFamilyLeader associated info
+ , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs)
+ , ppResultSig result unicode qual
+ , injAnn
+ , whereBit
+ ]
where
- wrapper = topDeclElem links loc splice [name]
+ whereBit = case info of
+ ClosedTypeFamily _ -> keyword "where ..."
+ _ -> noHtml
+
+ injAnn = case injectivity of
+ Nothing -> noHtml
+ Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"
+ : ppLDocName qual Raw lhs
+ : arrow unicode
+ : map (ppLDocName qual Raw) rhs)
+
+-- | Print the keywords that begin the family declaration
+ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html
+ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family")
+ where
+ typ = case info of
+ OpenTypeFamily -> "type"
+ ClosedTypeFamily _ -> "type"
+ DataFamily -> "data"
+
+-- | Print the signature attached to a family
+ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+ NoSig _ -> noHtml
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ XFamilyResultSig _ -> panic "haddock:ppResultSig"
--------------------------------------------------------------------------------
@@ -399,25 +394,10 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
-> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
+ ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
--------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
--- | Print a type family and its variables
-ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
-ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
- ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
-ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
-
--- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
-ppDataBinderWithVars summ unicode qual decl =
- ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
-
---------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
@@ -672,7 +652,9 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m
, mdoc
, [subFamInstDetails iid pdecl mname])
where
- pdata = keyword "data" <+> typ
+ nd = dd_ND (tcdDataDefn dd)
+ pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
+ pdata = pref <+> typ
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
@@ -684,9 +666,7 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
-> [PseudoFamilyDecl DocNameI]
-> [Html]
ppInstanceAssocTys links splice unicode qual =
- map ppFamilyDecl'
- where
- ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
+ map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual)
ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
@@ -1060,10 +1040,12 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
-ppDataHeader summary decl@(DataDecl { tcdDataDefn =
- HsDataDefn { dd_ND = nd
- , dd_ctxt = ctxt
- , dd_kindSig = ks } })
+ppDataHeader summary (DataDecl { tcdDataDefn =
+ HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt
+ , dd_kindSig = ks }
+ , tcdLName = L _ name
+ , tcdTyVars = tvs })
unicode qual
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
@@ -1071,7 +1053,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
-- context
ppLContext ctxt unicode qual HideEmptyContexts <+>
-- T a b c ..., or a :+: b
- ppDataBinderWithVars summary unicode qual decl
+ ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs)
<+> case ks of
Nothing -> mempty
Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
@@ -1120,7 +1102,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
-ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"
+ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 7fbaec6d..62781fd0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
dcolon, arrow, darrow, forallSymbol :: Bool -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6eee353b..f8c26175 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -36,9 +36,10 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey
- , tYPETyConKey, liftedRepDataConKey )
+import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
+ , unitTy, promotedNilDataCon, promotedConsDataCon )
+import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
+ , liftedRepDataConKey )
import Unique ( getUnique )
import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
, splitAtList )
@@ -118,8 +119,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
+ in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExt
, feqn_tycon = name
, feqn_pats = annot_typats
@@ -457,9 +457,24 @@ synifyType _ (TyConApp tc tys)
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) vis_tys)
+ | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys)
+ | Just dc <- isPromotedDataCon_maybe tc
+ , isTupleDataCon dc
+ , dataConSourceArity dc == length vis_tys
+ = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys)
-- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
+ | getName tc == listTyConName, [ty] <- vis_tys =
noLoc $ HsListTy noExt (synifyType WithinType ty)
+ | tc == promotedNilDataCon, [] <- vis_tys
+ = noLoc $ HsExplicitListTy noExt Promoted []
+ | tc == promotedConsDataCon
+ , [ty1, ty2] <- vis_tys
+ = let hTy = synifyType WithinType ty1
+ in case synifyType WithinType ty2 of
+ tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy
+ -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy')
+ | otherwise
+ -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
@@ -567,6 +582,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig k = synifyType WithinType k
+stripKindSig :: LHsType GhcRn -> LHsType GhcRn
+stripKindSig (L _ (HsKindSig _ t _)) = t
+stripKindSig t = t
+
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
@@ -652,8 +671,8 @@ tcSplitSigmaTyPreserveSynonyms ty =
tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)
tcSplitForAllTysPreserveSynonyms ty = split ty ty []
where
- split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..351a39d1 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -23,7 +23,7 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
import Control.Monad hiding (mapM)
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index ce6ecc78..30bd2b9a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807)
+#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
binaryInterfaceVersion = 33
binaryInterfaceVersionCompatibility :: [Word16]
@@ -190,8 +190,9 @@ readInterfaceFile :: forall m.
MonadIO m
=> NameCacheAccessor m
-> FilePath
+ -> Bool -- ^ Disable version check. Can cause runtime crash.
-> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
+readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
bh0 <- liftIO $ readBinMem filename
magic <- liftIO $ get bh0
@@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
"Magic number mismatch: couldn't load interface file: " ++ filename
- | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+ | not bypass_checks
+ , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
"Interface file is of wrong version: " ++ filename
| otherwise -> with_name_cache $ \update_nc -> do
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b5e987d8..46db572b 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -84,6 +84,7 @@ data Flag
| Flag_Version
| Flag_CompatibleInterfaceVersions
| Flag_InterfaceVersion
+ | Flag_BypassInterfaceVersonCheck
| Flag_UseContents String
| Flag_GenContents
| Flag_UseIndex String
@@ -175,6 +176,8 @@ options backwardsCompat =
"output compatible interface file versions and exit",
Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
"output interface file version and exit",
+ Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
+ "bypass the interface file version check (dangerous)",
Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
"set verbosity level",
Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
@@ -186,7 +189,7 @@ options backwardsCompat =
Option [] ["gen-index"] (NoArg Flag_GenIndex)
"generate an HTML index from specified\ninterfaces",
Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports atribute",
+ "behave as if all modules have the\nignore-exports attribute",
Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
"behave as if MODULE has the hide attribute",
Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 15:56:16 +0000