aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs25
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs6
-rw-r--r--haddock-api/src/Haddock/Convert.hs5
-rw-r--r--haddock-api/src/Haddock/Interface.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs11
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/Options.hs11
-rw-r--r--haddock-api/src/Haddock/Utils.hs4
9 files changed, 39 insertions, 34 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 44841bc5..2ef0c61b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -31,6 +31,7 @@ import GHC.Driver.Ppr
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.State
import Data.Char
import Data.List
@@ -46,8 +47,8 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
,""]
-ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
let -- Since Hoogle is line based, we want to avoid breaking long lines.
dflags' = dflags{ pprCols = maxBound }
filename = package ++ ".txt"
@@ -56,16 +57,16 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
["@package " ++ package] ++
["@version " ++ showVersion version
| not (null (versionBranch version)) ] ++
- concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
+ppModule :: DynFlags -> UnitState -> Interface -> [String]
+ppModule dflags unit_state iface =
"" : ppDocumentation dflags (ifaceDoc iface) ++
["module " ++ moduleString (ifaceMod iface)] ++
concatMap (ppExport dflags) (ifaceExportItems iface) ++
- concatMap (ppInstance dflags) (ifaceInstances iface)
+ concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
---------------------------------------------------------------------
@@ -204,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
_ -> decl
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x =
- [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]
+ppInstance dflags unit_state x =
+ [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]
where
-- As per #168, we don't want safety information about the class
-- in Hoogle output. The easiest way to achieve this is to set the
@@ -244,9 +245,9 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
-- AZ:TODO get rid of the concatMap
= concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
where
- f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
- f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
+ f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+ f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
+ f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
[(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 414b870d..52df9dc8 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -784,7 +784,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
header_ = ppConstrHdr forall_ tyVars context unicode
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args
+ PrefixCon _ args
| hasArgDocs -> header_ <+> ppOcc
| otherwise -> hsep [ header_
, ppOcc
@@ -823,7 +823,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- H98 record declarations
RecCon (L _ fields) -> doRecordFields fields
-- H98 prefix data constructors
- PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
-- H98 infix data constructor
InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
_ -> empty
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8b9739f1..e9806471 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -845,7 +845,7 @@ ppShortConstrParts summary dataInst con unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args ->
+ PrefixCon _ args ->
( header_ +++
hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
, noHtml
@@ -918,7 +918,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args
+ PrefixCon _ args
| hasArgDocs -> header_ +++ ppOcc <+> fixity
| otherwise -> hsep [ header_ +++ ppOcc
, hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
@@ -959,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- H98 record declarations
RecCon (L _ fields) -> [ doRecordFields fields ]
-- H98 prefix data constructors
- PrefixCon args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+ PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ]
-- H98 infix data constructor
InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
_ -> []
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2a711e5c..b59602b6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -93,10 +93,11 @@ tyThingToLHsDecl prr t = case t of
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
+ cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+ -- Without this signature, we trigger GHC#18932
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)
@@ -397,7 +398,7 @@ synifyDataCon use_gadt_syntax dc =
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
(True,False) -> return $ RecCon (noLoc field_tys)
- (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
+ (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
_ -> Left "synifyDataCon: infix with non-2 args?"
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 583cacf8..be9bd09a 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -159,10 +159,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do
IsBoot ->
return Nothing
NotBoot -> do
+ unit_state <- hsc_units <$> getSession
out verbosity verbose "Creating interface..."
(interface, msgs) <- {-# SCC createIterface #-}
withTimingD "createInterface" (const ()) $ do
- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap
-- We need to keep track of which modules were somehow in scope so that when
-- Haddock later looks for instances, it also looks in these modules too.
@@ -170,7 +171,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
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ home_unit = hsc_home_unit 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 a0e56f07..7ef64a94 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -47,6 +47,7 @@ import GHC.Types.SourceFile
import GHC.Core.ConLike (ConLike(..))
import GHC
import GHC.Driver.Ppr
+import GHC.Driver.Env
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
@@ -67,11 +68,12 @@ import GHC.Unit.Module.Warnings
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
createInterface :: TypecheckedModule
+ -> UnitState
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm unit_state flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -84,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
!exportedNames = modInfoExportsWithSelectors mi
- (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
+ (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl)
pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
(TcGblEnv { tcg_rdr_env = gre
@@ -164,8 +166,7 @@ createInterface tm flags modMap instIfaceMap = do
| otherwise = exportItems
!prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
- let !aliases =
- mkAliasMap (unitState dflags) $ tm_renamed_source tm
+ let !aliases = mkAliasMap unit_state $ tm_renamed_source tm
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
@@ -948,7 +949,7 @@ extractPatternSyn nm t tvs cons =
let args =
case con of
ConDeclH98 { con_args = con_args' } -> case con_args' of
- PrefixCon args' -> map hsScaledThing args'
+ PrefixCon _ args' -> map hsScaledThing args'
RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index a1e712e0..5d7b4f1a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -516,7 +516,7 @@ renameH98Details :: HsConDeclH98Details GhcRn
renameH98Details (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
return (RecCon (L l fields'))
-renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
renameH98Details (InfixCon a b) = do
a' <- renameHsScaled a
b' <- renameHsScaled b
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 5c9bf448..eda40935 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -45,7 +45,8 @@ import Data.Version
import Control.Applicative
import Distribution.Verbosity
import GHC.Data.FastString
-import GHC ( DynFlags, Module, moduleUnit, unitState )
+import GHC ( DynFlags, Module, moduleUnit )
+import GHC.Unit.State
import Haddock.Types
import Haddock.Utils
import GHC.Unit.State
@@ -370,16 +371,16 @@ optLast xs = Just (last xs)
--
-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
-- specify this information manually and it is returned here if present.
-modulePackageInfo :: DynFlags
+modulePackageInfo :: UnitState
-> [Flag] -- ^ Haddock flags are checked as they may contain
-- the package name or version provided by the user
-- which we prioritise
-> Maybe Module
-> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
-modulePackageInfo dflags flags (Just modu) =
+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
+modulePackageInfo unit_state flags (Just modu) =
( optPackageName flags <|> fmap unitPackageName pkgDb
, optPackageVersion flags <|> fmap unitPackageVersion pkgDb
)
where
- pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)
+ pkgDb = lookupUnit unit_state (moduleUnit modu)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index aec7f9ab..8186e3b7 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -210,10 +210,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
ConDeclGADT { con_g_args = args } -> restrict_gadt_args args
where
restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn)
- restrict_h98_args (PrefixCon _) = Just d
+ restrict_h98_args (PrefixCon _ _) = Just d
restrict_h98_args (RecCon (L _ fields))
| all field_avail fields = Just d
- | otherwise = Just (d { con_args = PrefixCon (field_types fields) })
+ | otherwise = Just (d { con_args = PrefixCon noTypeArgs (field_types fields) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 13:41:13 +0000