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/Hoogle.hs34
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs30
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs111
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs19
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs171
-rw-r--r--haddock-api/src/Haddock/Convert.hs252
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs31
-rw-r--r--haddock-api/src/Haddock/Interface.hs19
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs13
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs519
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs159
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs61
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs13
-rw-r--r--haddock-api/src/Haddock/Types.hs85
-rw-r--r--haddock-api/src/Haddock/Utils.hs20
18 files changed, 824 insertions, 740 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 4b4bad4c..f7fa52b3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -43,7 +43,7 @@ import Haddock.Utils
import Control.Monad hiding (forM_)
import Control.Applicative
-import Data.Foldable (forM_)
+import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
import Control.Exception
@@ -166,7 +166,6 @@ haddockWithGhc ghc args = handleTopExceptions $ do
hPutStrLn stderr warning
ghc flags' $ do
-
dflags <- getDynFlags
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
@@ -429,8 +428,11 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
ghcMode = CompManager,
ghcLink = NoLink
}
- let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs
-
+ -- We disable pattern match warnings because than can be very
+ -- expensive to check
+ let dynflags'' = unsetPatternMatchWarnings $
+ updOptLevel 0 $
+ gopt_unset dynflags' Opt_SplitObjs
-- ignore the following return-value, which is a list of packages
-- that may need to be re-linked: Haddock doesn't do any
-- dynamic or static linking at all!
@@ -446,6 +448,17 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
then throwE ("Couldn't parse GHC options: " ++ unwords flags)
else return dynflags'
+unsetPatternMatchWarnings :: DynFlags -> DynFlags
+unsetPatternMatchWarnings dflags =
+ foldl' wopt_unset dflags pattern_match_warnings
+ where
+ pattern_match_warnings =
+ [ Opt_WarnIncompletePatterns
+ , Opt_WarnIncompleteUniPatterns
+ , Opt_WarnIncompletePatternsRecUpd
+ , Opt_WarnOverlappingPatterns
+ ]
+
-------------------------------------------------------------------------------
-- * Misc
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 3a9f6e43..f1d8ddb2 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -87,7 +87,7 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: (OutputableBndrId a)
+outHsType :: (SourceTextX a, OutputableBndrId a)
=> DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
@@ -118,7 +118,7 @@ commaSeparate dflags = showSDocUnqual dflags . interpp'SP
---------------------------------------------------------------------
-- How to print each export
-ppExport :: DynFlags -> ExportItem Name -> [String]
+ppExport :: DynFlags -> ExportItem GhcRn -> [String]
ppExport dflags ExportDecl { expItemDecl = L _ decl
, expItemMbDoc = (dc, _)
, expItemSubDocs = subdocs
@@ -136,7 +136,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
ppFixities = concatMap (ppFixity dflags) fixities
ppExport _ _ = []
-ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]
+ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags (TypeSig names sig) subdocs
= concatMap mkDocSig names
where
@@ -148,17 +148,17 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs
ppSigWithDoc _ _ _ = []
-ppSig :: DynFlags -> Sig Name -> [String]
+ppSig :: DynFlags -> Sig GhcRn -> [String]
ppSig dflags x = ppSigWithDoc dflags x []
-pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String
+pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String
pp_sig dflags names (L _ typ) =
operator prettyNames ++ " :: " ++ outHsType dflags typ
where
prettyNames = intercalate ", " $ map (out dflags) names
-- note: does not yet output documentation for class methods
-ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppClass dflags decl subdocs =
(out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}
++ ppTyFams) : ppMethods
@@ -178,17 +178,17 @@ ppClass dflags decl subdocs =
whereWrapper elems = vcat'
[ text "where" <+> lbrace
- , nest 4 . vcat . map (<> semi) $ elems
+ , nest 4 . vcat . map (Outputable.<> semi) $ elems
, rbrace
]
- tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name
+ tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn
tyFamEqnToSyn tfe = SynDecl
- { tcdLName = tfe_tycon tfe
- , tcdTyVars = tfe_pats tfe
- , tcdFixity = tfe_fixity tfe
- , tcdRhs = tfe_rhs tfe
- , tcdFVs = emptyNameSet
+ { tcdLName = feqn_tycon tfe
+ , tcdTyVars = feqn_pats tfe
+ , tcdFixity = feqn_fixity tfe
+ , tcdRhs = feqn_rhs tfe
+ , tcdFVs = emptyNameSet
}
@@ -204,10 +204,10 @@ ppInstance dflags x =
cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText
, isSafeOverlap = False } }
-ppSynonym :: DynFlags -> TyClDecl Name -> [String]
+ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String]
ppSynonym dflags x = [out dflags x]
-ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
= showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
@@ -228,7 +228,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
Just (d, _) -> ppDocumentation dflags d
_ -> []
-ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
ppCtor dflags dat subdocs con@ConDeclH98 {}
-- AZ:TODO get rid of the concatMap
= concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)
@@ -262,7 +262,7 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {}
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 9d273417..57ff72ff 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -84,13 +84,13 @@ variables =
everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
- (Just (GHC.L sspan (GHC.HsVar name))) ->
+ (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
pure (sspan, RtkVar (GHC.unLoc name))
(Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
- Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->
+ Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
pure (sspan, RtkVar name)
_ -> empty
@@ -99,7 +99,7 @@ types :: GHC.RenamedSource -> LTokenDetails
types = everythingInRenamedSource ty
where
ty term = case cast term of
- (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->
+ (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
@@ -114,11 +114,11 @@ binds = everythingInRenamedSource
(fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
_ -> empty
pat term = case cast term of
- (Just (GHC.L sspan (GHC.VarPat name))) ->
+ (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
@@ -126,11 +126,11 @@ binds = everythingInRenamedSource
pure (sspan, RtkBind name)
_ -> empty
rec term = case cast term of
- (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
+ (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) ->
pure (sspan, RtkVar name)
_ -> empty
tvar term = case cast term of
- (Just (GHC.L sspan (GHC.UserTyVar name))) ->
+ (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
@@ -150,21 +150,23 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
- (Just cdcl) ->
+ (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
map decl (GHC.getConNames cdcl)
++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
- (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
- (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->
- pure . tyref $ GHC.tfe_tycon eqn
+ (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
+ :: GHC.InstDecl GHC.GhcRn))
+ -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
+ (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
+ pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
_ -> empty
fld term = case cast term of
- Just (field :: GHC.ConDeclField GHC.Name)
+ Just (field :: GHC.ConDeclField GHC.GhcRn)
-> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
@@ -181,7 +183,7 @@ imports src@(_, imps, _, _) =
everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
(Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith t _ vs _fls)) ->
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1b248d2e..d79e0e6c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -37,6 +37,7 @@ import Data.Char
import Control.Monad
import Data.Maybe
import Data.List
+import Prelude hiding ((<>))
import Haddock.Doc (combineDocumentation)
@@ -179,7 +180,7 @@ string_txt (ZStr s1) s2 = zString s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
-exportListItem :: ExportItem DocName -> LaTeX
+exportListItem :: ExportItem DocNameI -> LaTeX
exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
= sep (punctuate comma . map ppDocBinder $ declNames decl) <>
case subdocs of
@@ -197,7 +198,7 @@ exportListItem _
-- Deal with a group of undocumented exports together, to avoid lots
-- of blank vertical space between them.
-processExports :: [ExportItem DocName] -> LaTeX
+processExports :: [ExportItem DocNameI] -> LaTeX
processExports [] = empty
processExports (decl : es)
| Just sig <- isSimpleSig decl
@@ -213,19 +214,19 @@ processExports (e : es) =
processExport e $$ processExports es
-isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
-isExportModule :: ExportItem DocName -> Maybe Module
+isExportModule :: ExportItem DocNameI -> Maybe Module
isExportModule (ExportModule m) = Just m
isExportModule _ = Nothing
-processExport :: ExportItem DocName -> LaTeX
+processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
@@ -248,7 +249,7 @@ ppDocGroup lev doc = sec lev <> braces doc
sec _ = text "\\paragraph"
-declNames :: LHsDecl DocName -> [DocName]
+declNames :: LHsDecl DocNameI -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
SigD (TypeSig lnames _ ) -> map unLoc lnames
@@ -258,7 +259,7 @@ declNames (L _ decl) = case decl of
_ -> error "declaration not supported by declNames"
-forSummary :: (ExportItem DocName) -> Bool
+forSummary :: (ExportItem DocNameI) -> Bool
forSummary (ExportGroup _ _ _) = False
forSummary (ExportDoc _) = False
forSummary _ = True
@@ -278,10 +279,10 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
-------------------------------------------------------------------------------
-ppDecl :: LHsDecl DocName
- -> [(HsDecl DocName,DocForDecl DocName)]
+ppDecl :: LHsDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
-> DocForDecl DocName
- -> [DocInstance DocName]
+ -> [DocInstance DocNameI]
-> [(DocName, DocForDecl DocName)]
-> [(DocName, Fixity)]
-> LaTeX
@@ -309,12 +310,12 @@ ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case dec
ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> LaTeX
+ TyClDecl DocNameI -> Bool -> LaTeX
ppTyFam _ _ _ _ _ =
error "type family declarations are currently not supported by --latex"
-ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
+ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =
ppFunSig loc doc [name] (hsSigType typ) unicode
ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
@@ -327,7 +328,7 @@ ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- we skip type patterns for now
-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
+ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype }) unicode
@@ -346,7 +347,7 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI
-> Bool -> LaTeX
ppFunSig loc doc docnames (L _ typ) unicode =
ppTypeOrFunSig loc docnames typ doc
@@ -358,7 +359,7 @@ ppFunSig loc doc docnames (L _ typ) unicode =
names = map getName docnames
ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]
- -> LHsSigType DocName
+ -> LHsSigType DocNameI
-> Bool -> LaTeX
ppLPatSig _loc (doc, _argDocs) docnames ty unicode
= declWithDoc pref1 (documentationToLaTeX doc)
@@ -369,7 +370,7 @@ ppLPatSig _loc (doc, _argDocs) docnames ty unicode
, ppLType unicode (hsSigType ty)
]
-ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
-> Bool -> LaTeX
ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
@@ -387,7 +388,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
- do_args :: Int -> LaTeX -> HsType DocName -> LaTeX
+ do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX
do_args _n leader (HsForAllTy tvs ltype)
= decltt leader
<-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
@@ -403,18 +404,18 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
= decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
-ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX
+ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
<+> dcolon unicode
<+> ppType unicode ty
-ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX]
ppTyVars = map (ppSymName . getName . hsLTyVarName)
-tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
@@ -463,8 +464,8 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
+ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
@@ -482,9 +483,9 @@ ppFds fds unicode =
hsep (map (ppDocName . unLoc) vars2)
-ppClassDecl :: [DocInstance DocName] -> SrcSpan
+ppClassDecl :: [DocInstance DocNameI] -> SrcSpan
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
- -> TyClDecl DocName -> Bool -> LaTeX
+ -> TyClDecl DocNameI -> Bool -> LaTeX
ppClassDecl instances loc doc subdocs
(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
@@ -519,7 +520,7 @@ ppClassDecl instances loc doc subdocs
ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX
+ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX
ppDocInstances _unicode [] = empty
ppDocInstances unicode (i : rest)
| Just ihead <- isUndocdInstance i
@@ -537,22 +538,22 @@ isUndocdInstance _ = Nothing
-- | Print a possibly commented instance. The instance header is printed inside
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
-ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
+ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX
ppDocInstance unicode (instHead, doc, _) =
declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
-ppInstDecl :: Bool -> InstHead DocName -> LaTeX
+ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
-ppInstHead :: Bool -> InstHead DocName -> LaTeX
+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"
where
- typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+ typ = ppAppNameTypes ihdClsName ihdTypes unicode
tibody = maybe empty (\t -> equals <+> ppType unicode t)
lookupAnySubdoc :: (Eq name1) =>
@@ -567,9 +568,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-------------------------------------------------------------------------------
-ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] ->
+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->
[(DocName, DocForDecl DocName)] -> SrcSpan ->
- Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
+ Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->
LaTeX
ppDataDecl pats instances subdocs _loc doc dataDecl unicode
@@ -615,7 +616,7 @@ ppDataDecl pats instances subdocs _loc doc dataDecl unicode
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX
+ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX
ppConstrHdr forall tvs ctxt unicode
= (if null tvs then empty else ppForall)
<+>
@@ -627,7 +628,7 @@ ppConstrHdr forall tvs ctxt unicode
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
- -> LConDecl DocName -> LaTeX
+ -> LConDecl DocNameI -> LaTeX
ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
leader <->
case con_details con of
@@ -756,7 +757,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
mkFunTy a b = noLoc (HsFunTy a b)
-}
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
@@ -814,7 +815,7 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
+ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX
ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
, tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
= -- newtype or data
@@ -830,27 +831,27 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX
-ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
+-- | Print an application of a DocName to its list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
ppAppDocNameNames _summ n ns =
- ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
+ ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
+ppTypeApp n (t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
opApp = ppT t1 <+> ppDN n <+> ppT t2
-ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
@@ -858,29 +859,29 @@ ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
+ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX
+ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
-ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
+ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX
ppContextNoArrow cxt unicode = fromMaybe empty $
ppContextNoLocsMaybe (map unLoc cxt) unicode
-ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
+ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX
ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $
ppContextNoLocsMaybe cxt unicode
-ppContext :: HsContext DocName -> Bool -> LaTeX
+ppContext :: HsContext DocNameI -> Bool -> LaTeX
ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
-pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
+pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX
pp_hs_context [] _ = empty
pp_hs_context [p] unicode = ppType unicode p
pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
@@ -930,32 +931,32 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX
ppLType unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
-ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX
+ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX
ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
-ppLKind :: Bool -> LHsKind DocName -> LaTeX
+ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
-ppKind :: Bool -> HsKind DocName -> LaTeX
+ppKind :: Bool -> HsKind DocNameI -> LaTeX
ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
+ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX
ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
-ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
+ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX
ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
= maybeParen ctxt_prec pREC_FUN $
sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
@@ -1018,7 +1019,7 @@ ppr_tylit (HsStrTy _ s) _ = text (show s)
-- XXX: Do something with Unicode parameter?
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX
ppr_fun_ty ctxt_prec ty1 ty2 unicode
= let p1 = ppr_mono_lty pREC_FUN ty1 unicode
p2 = ppr_mono_lty pREC_TOP ty2 unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index cf8d7e4f..55175163 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -368,7 +368,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
qual = makeModuleQual qual_opt aliases mdl
mdl = ifaceMod iface
- goExport :: Module -> Qualification -> ExportItem DocName -> [Value]
+ goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
goExport mdl qual item
| Just item_html <- processExport True links_info unicode qual item
= [ Object
@@ -382,12 +382,12 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
where
names = exportName item ++ exportSubs item
- exportSubs :: ExportItem DocName -> [DocName]
+ exportSubs :: ExportItem name -> [IdP name]
exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
exportSubs _ = []
- exportName :: ExportItem DocName -> [DocName]
- exportName ExportDecl { expItemDecl } = getMainDeclBinder $ unLoc expItemDecl
+ exportName :: ExportItem name -> [IdP name]
+ exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
exportName ExportNoDecl { expItemName } = [expItemName]
exportName _ = []
@@ -563,6 +563,7 @@ ppHtmlModule odir doctitle themes
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
+
ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
= ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++
@@ -616,7 +617,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
ppModuleContents :: Qualification
- -> [ExportItem DocName]
+ -> [ExportItem DocNameI]
-> Bool -- ^ Orphans sections
-> Html
ppModuleContents qual exports orphan
@@ -632,7 +633,7 @@ ppModuleContents qual exports orphan
| orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ]
| otherwise = []
- process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
+ process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI])
process _ [] = ([], [])
process n items@(ExportGroup lev id0 doc : rest)
| lev <= n = ( [], items )
@@ -649,9 +650,9 @@ ppModuleContents qual exports orphan
-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
-numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
+numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI]
numberSectionHeadings = go 1
- where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
+ where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]
go _ [] = []
go n (ExportGroup lev _ doc : es)
= ExportGroup lev (show n) doc : go (n+1) es
@@ -660,7 +661,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
- -> ExportItem DocName -> Maybe Html
+ -> ExportItem DocNameI -> Maybe Html
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index c78bee2d..3b85f96c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -40,9 +40,9 @@ import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
-ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
- -> [(HsDecl DocName, DocForDecl DocName)]
- -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
+ -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
@@ -60,14 +60,14 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
+ [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
ppFunSig summary links loc doc (map unLoc lnames) lty fixities
splice unicode qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
+ [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
@@ -76,7 +76,7 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
pp_typ = ppLType unicode qual HideEmptyContexts typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsSigType DocName ->
+ [Located DocName] -> LHsSigType DocNameI ->
[(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual
@@ -91,7 +91,7 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode
]
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
- [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
+ [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
splice unicode qual emptyCtxts =
@@ -108,7 +108,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
| otherwise = html <+> ppFixities fixities qual
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
-> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
@@ -122,7 +122,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
do_largs n leader (L _ t) = do_args n leader t
- do_args :: Int -> Html -> HsType DocName -> [SubDecl]
+ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
do_args n leader (HsForAllTy tvs ltype)
= do_largs n leader' ltype
where
@@ -141,7 +141,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
do_args n leader t
= [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
-ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html
+ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
[] -> noHtml
@@ -172,15 +172,15 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
-- | Pretty-print type variables.
-ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html]
+ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
-tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> ForeignDecl DocName -> [(DocName, Fixity)]
+ -> ForeignDecl DocNameI -> [(DocName, Fixity)]
-> Splice -> Unicode -> Qualification -> Html
ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
splice unicode qual
@@ -190,7 +190,7 @@ ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
- -> DocForDecl DocName -> TyClDecl DocName
+ -> DocForDecl DocName -> TyClDecl DocNameI
-> Splice -> Unicode -> Qualification -> Html
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype })
@@ -221,7 +221,7 @@ ppTyName = ppName Prefix
ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
- -> [DocName] -> HsType DocName
+ -> [DocName] -> HsType DocNameI
-> Html
ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
@@ -236,7 +236,7 @@ ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
--------------------------------------------------------------------------------
-ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html
+ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html
ppFamilyInfo assoc OpenTypeFamily
| assoc = keyword "type"
| otherwise = keyword "type family"
@@ -246,7 +246,7 @@ ppFamilyInfo assoc DataFamily
ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI
-> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
, fdResultSig = L _ result
@@ -276,28 +276,28 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
_ -> mempty
)
-ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+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
-ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
+ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
-> Html
ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
ppFamilyInfo True pfdInfo <+>
- ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
+ ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
ppResultSig (unLoc pfdKindSig) unicode qual
-ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
+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 DocName] ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
[(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
+ FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html
ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
@@ -318,16 +318,17 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= ppInstances links (OriginFamily docname) instances splice unicode qual
-- Individual equation of a closed type family
- ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
- , tfe_pats = HsIB { hsib_body = ts }}
- = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
+ 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
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
- -> PseudoFamilyDecl DocName
+ -> PseudoFamilyDecl DocNameI
-> Html
ppPseudoFamilyDecl links splice unicode qual
decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
@@ -341,7 +342,7 @@ ppPseudoFamilyDecl links splice unicode qual
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
-> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
@@ -352,12 +353,12 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
--------------------------------------------------------------------------------
-- | Print a type family and its variables
-ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html
+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)
-- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html
+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
ppDataBinderWithVars summ unicode qual decl =
ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
@@ -365,31 +366,30 @@ ppDataBinderWithVars summ unicode qual decl =
-- * Type applications
--------------------------------------------------------------------------------
-ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html
+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
- ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
+ ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
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)
-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 HideEmptyContexts)
+-- | Print an application of a 'DocName' to its list of 'HsType's
+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html
+ppAppNameTypes n ts unicode qual =
+ ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n (t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
-ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
+ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
@@ -397,33 +397,33 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
+ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
-> Qualification -> HideEmptyContexts -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
-ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $
ppContextNoLocsMaybe cxt unicode qual emptyCtxts
-ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
+ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
ppContextNoLocsMaybe [] _ _ emptyCtxts =
case emptyCtxts of
HideEmptyContexts -> Nothing
ShowEmptyToplevelContexts -> Just (toHtml "()")
ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
-ppContext :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts
-ppHsContext :: [HsType DocName] -> Unicode -> Qualification -> Html
+ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html
ppHsContext [] _ _ = noHtml
ppHsContext [p] unicode qual = ppCtxType unicode qual p
ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)
@@ -434,8 +434,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
+ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -452,7 +452,7 @@ ppFds fds unicode qual =
fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
-> [(DocName, DocForDecl DocName)]
-> Splice -> Unicode -> Qualification -> Html
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
@@ -484,9 +484,9 @@ ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppSh
-ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]
-> SrcSpan -> Documentation DocName
- -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
+ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
-> Splice -> Unicode -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
@@ -557,7 +557,7 @@ ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppS
ppInstances :: LinksInfo
- -> InstOrigin DocName -> [DocInstance DocName]
+ -> InstOrigin DocName -> [DocInstance DocNameI]
-> Splice -> Unicode -> Qualification
-> Html
ppInstances links origin instances splice unicode qual
@@ -565,22 +565,22 @@ ppInstances links origin instances splice unicode qual
-- force Splice = True to use line URLs
where
instName = getOccString origin
- instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
instDecl no (inst, mdoc, loc) =
((ppInstHead links splice unicode qual mdoc origin False no inst), loc)
ppOrphanInstances :: LinksInfo
- -> [DocInstance DocName]
+ -> [DocInstance DocNameI]
-> Splice -> Unicode -> Qualification
-> Html
ppOrphanInstances links instances splice unicode qual
= subOrphanInstances qual links True (zipWith instDecl [1..] instances)
where
- instOrigin :: InstHead name -> InstOrigin name
+ instOrigin :: InstHead name -> InstOrigin (IdP name)
instOrigin inst = OriginClass (ihdClsName inst)
- instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)
instDecl no (inst, mdoc, loc) =
((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)
@@ -590,7 +590,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-> InstOrigin DocName
-> Bool -- ^ Is instance orphan
-> Int -- ^ Normal
- -> InstHead DocName
+ -> InstHead DocNameI
-> SubDecl
ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
case ihdInstType of
@@ -620,11 +620,11 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
- typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+ typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
- -> [PseudoFamilyDecl DocName]
+ -> [PseudoFamilyDecl DocNameI]
-> [Html]
ppInstanceAssocTys links splice unicode qual =
map ppFamilyDecl'
@@ -633,7 +633,7 @@ ppInstanceAssocTys links splice unicode qual =
ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
- -> [Sig DocName]
+ -> [Sig DocNameI]
-> [Html]
ppInstanceSigs links splice unicode qual sigs = do
TypeSig lnames typ <- sigs
@@ -648,7 +648,7 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String
+instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String
instanceId origin no orphan ihd = concat $
[ "o:" | orphan ] ++
[ qual origin
@@ -668,8 +668,8 @@ instanceId origin no orphan ihd = concat $
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName
- -> [(HsDecl DocName,DocForDecl DocName)]
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
-> Unicode -> Qualification -> Html
ppShortDataDecl summary dataInst dataDecl pats unicode qual
@@ -707,10 +707,10 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
]
-ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Documentation DocName -> TyClDecl DocName ->
- [(HsDecl DocName,DocForDecl DocName)] ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
+ [(HsDecl DocNameI, DocForDecl DocName)] ->
Splice -> Unicode -> Qualification -> Html
ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode qual
@@ -759,7 +759,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
-ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
+ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html
ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
where
(cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual
@@ -767,7 +767,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
-ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
+ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)
ppShortConstrParts summary dataInst con unicode qual = case con of
ConDeclH98{} -> case con_details con of
PrefixCon args ->
@@ -808,7 +808,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode
+ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode
-> Qualification -> Html
ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
@@ -822,7 +822,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
| otherwise = noHtml
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
+ -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl
ppSideBySideConstr subdocs fixities unicode qual (L _ con)
= (decl, mbDoc, fieldPart)
where
@@ -852,7 +852,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
doRecordFields fields = subFields qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
- doGADTCon :: Located (HsType DocName) -> Html
+ doGADTCon :: Located (HsType DocNameI) -> Html
doGADTCon ty = ppOcc <+> dcolon unicode
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
<+> ppLType unicode qual HideEmptyContexts ty
@@ -880,7 +880,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
- -> ConDeclField DocName -> SubDecl
+ -> ConDeclField DocNameI -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode
@@ -894,7 +894,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
-ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
@@ -902,7 +902,7 @@ ppShortField summary unicode qual (ConDeclField names ltype _)
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
+ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
ppDataHeader summary decl@(DataDecl { tcdDataDefn =
HsDataDefn { dd_ND = nd
, dd_ctxt = ctxt
@@ -964,33 +964,33 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocName) -> Html
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
-ppCtxType :: Unicode -> Qualification -> HsType DocName -> Html
+ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts
-ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocName -> Html
+ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html
ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
-ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html
+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)
-ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
+ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
-ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
+ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
-ppPatSigType :: Unicode -> Qualification -> LHsType DocName -> Html
+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts =
if hasNonEmptyContext typ && isFirstContextEmpty typ
@@ -1013,14 +1013,14 @@ ppPatSigType unicode qual typ =
HsFunTy _ s -> isFirstContextEmpty s
_ -> False
-ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
-ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
@@ -1089,8 +1089,7 @@ ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
= let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4aaaed9d..96a08555 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,3 +1,4 @@
+
{-# LANGUAGE CPP, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
@@ -24,6 +25,7 @@ import ConLike
import Data.Either (lefts, rights)
import DataCon
import FamInstEnv
+import FV
import HsSyn
import Name
import NameSet ( emptyNameSet )
@@ -36,11 +38,13 @@ import Type
import TyCoRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, ipClassKey
+import PrelNames ( hasKey, eqTyConKey, funTyConKey, ipClassKey
, tYPETyConKey, liftedRepDataConKey )
import Unique ( getUnique )
-import Util ( filterByList, filterOut )
+import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
+ , splitAtList )
import Var
+import VarSet
import Haddock.Types
import Haddock.Interface.Specialize
@@ -48,7 +52,7 @@ import Haddock.Interface.Specialize
-- the main function here! yay!
-tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))
+tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn))
tyThingToLHsDecl t = case t of
-- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
-- Including built-in functions like seq.
@@ -76,7 +80,7 @@ tyThingToLHsDecl t = case t of
in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
- , tcdTyVars = synifyTyVars (classTyVars cl)
+ , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
, tcdFixity = Prefix
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
@@ -107,25 +111,30 @@ tyThingToLHsDecl t = case t of
withErrs e x = return (e, x)
allOK x = return (mempty, x)
-synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
+synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
- = let name = synifyName tc
- typats = map (synifyType WithinType) args
- hs_rhs = synifyType WithinType rhs
- in TyFamEqn { tfe_tycon = name
- , tfe_pats = HsIB { hsib_body = typats
- , hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
- , tfe_fixity = Prefix
- , tfe_rhs = hs_rhs }
-
-synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
+ = let name = synifyName tc
+ args_types_only = filterOutInvisibleTypes tc args
+ typats = map (synifyType WithinType) args_types_only
+ annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
+ args_types_only typats
+ hs_rhs = synifyType WithinType rhs
+ in HsIB { hsib_vars = map tyVarName tkvs
+ , hsib_closed = True
+ , hsib_body = FamEqn { feqn_tycon = name
+ , feqn_pats = annot_typats
+ , feqn_fixity = Prefix
+ , feqn_rhs = hs_rhs } }
+ where
+ fam_tvs = tyConVisibleTyVars tc
+
+synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
- = return $ InstD (TyFamInstD
- (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
- , tfid_fvs = placeHolderNamesTc }))
+ = return $ InstD
+ $ TyFamInstD
+ $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
@@ -135,7 +144,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
= Left "synifyAxiom: closed/open family confusion"
-- | Turn type constructors into type class declarations
-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)
+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn)
synifyTyCon _coax tc
| isFunTyCon tc || isPrimTyCon tc
= return $
@@ -184,19 +193,19 @@ synifyTyCon _coax tc
mkFamDecl i = return $ FamDecl $
FamilyDecl { fdInfo = i
, fdLName = synifyName tc
- , fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = Prefix
, fdResultSig =
synifyFamilyResultSig resultVar (tyConResKind tc)
, fdInjectivityAnn =
synifyInjectivityAnn resultVar (tyConTyVars tc)
- (familyTyConInjectivityInfo tc)
+ (tyConInjectivityInfo tc)
}
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdLName = synifyName tc
- , tcdTyVars = synifyTyVars (tyConTyVars tc)
+ , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = Prefix
, tcdRhs = synifyType WithinType ty
, tcdFVs = placeHolderNamesTc }
@@ -209,7 +218,7 @@ synifyTyCon coax tc
Just a -> synifyName a -- Data families are named according to their
-- CoAxioms, not their TyCons
_ -> synifyName tc
- tyvars = synifyTyVars (tyConTyVars tc)
+ tyvars = synifyTyVars (tyConVisibleTyVars tc)
kindSig = Just (tyConKind tc)
-- The data constructors.
--
@@ -246,14 +255,14 @@ synifyTyCon coax tc
dataConErrs -> Left $ unlines dataConErrs
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
- -> Maybe (LInjectivityAnn Name)
+ -> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn Nothing _ _ = Nothing
synifyInjectivityAnn _ _ NotInjective = Nothing
synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
let rhs = map (noLoc . tyVarName) (filterByList inj tvs)
in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs
-synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name
+synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind =
noLoc $ KindSig (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
@@ -264,7 +273,7 @@ synifyFamilyResultSig (Just name) kind =
-- result-type.
-- But you might want pass False in simple enough cases,
-- if you think it looks better.
-synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name)
+synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn)
synifyDataCon use_gadt_syntax dc =
let
-- dataConIsInfix allegedly tells us whether it was declared with
@@ -321,22 +330,22 @@ synifyName :: NamedThing n => n -> Located Name
synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
-synifyIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn
synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
-synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn
synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i))
-synifyCtx :: [PredType] -> LHsContext Name
+synifyCtx :: [PredType] -> LHsContext GhcRn
synifyCtx = noLoc . map (synifyType WithinType)
-synifyTyVars :: [TyVar] -> LHsQTyVars Name
+synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs = HsQTvs { hsq_implicit = []
, hsq_explicit = map synifyTyVar ktvs
, hsq_dependent = emptyNameSet }
-synifyTyVar :: TyVar -> LHsTyVarBndr Name
+synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar tv
| isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))
| otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
@@ -344,6 +353,33 @@ synifyTyVar tv
kind = tyVarKind tv
name = getName tv
+-- | Annotate (with HsKingSig) a type if the first parameter is True
+-- and if the type contains a free variable.
+-- This is used to synify type patterns for poly-kinded tyvars in
+-- synifying class and type instances.
+annotHsType :: Bool -- True <=> annotate
+ -> Type -> LHsType GhcRn -> LHsType GhcRn
+ -- tiny optimization: if the type is annotated, don't annotate again.
+annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty
+annotHsType True ty hs_ty
+ | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
+ = let ki = typeKind ty
+ hs_ki = synifyType WithinType ki
+ in noLoc (HsKindSig hs_ty hs_ki)
+annotHsType _ _ hs_ty = hs_ty
+
+-- | For every type variable in the input,
+-- report whether or not the tv is poly-kinded. This is used to eventually
+-- feed into 'annotHsType'.
+mkIsPolyTvs :: [TyVar] -> [Bool]
+mkIsPolyTvs = map is_poly_tv
+ where
+ is_poly_tv tv = not $
+ isEmptyVarSet $
+ filterVarSet isTyVar $
+ tyCoVarsOfType $
+ tyVarKind tv
+
--states of what to do with foralls:
data SynifyTypeState
= WithinType
@@ -360,53 +396,84 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
-synifySigType :: SynifyTypeState -> Type -> LHsSigType Name
+synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn
-- The empty binders is a bit suspicious;
-- what if the type has free variables?
synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
-synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
+synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty))
-synifyPatSynSigType :: PatSyn -> LHsSigType Name
+synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
-synifyType :: SynifyTypeState -> Type -> LHsType Name
+synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
- -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
- | tc `hasKey` tYPETyConKey
- , [TyConApp lev []] <- tys
- , lev `hasKey` liftedRepDataConKey
- = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
- -- Use non-prefix tuple syntax where possible, because it looks nicer.
- | Just sort <- tyConTuple_maybe tc
- , tyConArity tc == length tys
- = noLoc $ HsTupleTy (case sort of
- BoxedTuple -> HsBoxedTuple
- ConstraintTuple -> HsConstraintTuple
- UnboxedTuple -> HsUnboxedTuple)
- (map (synifyType WithinType) tys)
- -- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy (synifyType WithinType ty)
- -- ditto for implicit parameter tycons
- | tc `hasKey` ipClassKey
- , [name, ty] <- tys
- , Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
- -- and equalities
- | tc `hasKey` eqTyConKey
- , [ty1, ty2] <- tys
- = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
- -- Most TyCons:
- | otherwise =
- foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
- (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
- (map (synifyType WithinType) $
- filterOut isCoercionTy tys)
+ = maybe_sig res_ty
+ where
+ res_ty :: LHsType GhcRn
+ res_ty
+ -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
+ | tc `hasKey` tYPETyConKey
+ , [TyConApp lev []] <- tys
+ , lev `hasKey` liftedRepDataConKey
+ = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
+ -- Use non-prefix tuple syntax where possible, because it looks nicer.
+ | Just sort <- tyConTuple_maybe tc
+ , tyConArity tc == length tys
+ = noLoc $ HsTupleTy (case sort of
+ BoxedTuple -> HsBoxedTuple
+ ConstraintTuple -> HsConstraintTuple
+ UnboxedTuple -> HsUnboxedTuple)
+ (map (synifyType WithinType) vis_tys)
+ -- ditto for lists
+ | getName tc == listTyConName, [ty] <- tys =
+ noLoc $ HsListTy (synifyType WithinType ty)
+ -- ditto for implicit parameter tycons
+ | tc `hasKey` ipClassKey
+ , [name, ty] <- tys
+ , Just x <- isStrLitTy name
+ = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
+ -- and equalities
+ | tc `hasKey` eqTyConKey
+ , [ty1, ty2] <- tys
+ = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+ -- Most TyCons:
+ | otherwise =
+ foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+ (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
+ (map (synifyType WithinType) $
+ filterOut isCoercionTy vis_tys)
+
+ vis_tys = filterOutInvisibleTypes tc tys
+ binders = tyConBinders tc
+ res_kind = tyConResKind tc
+
+ maybe_sig :: LHsType GhcRn -> LHsType GhcRn
+ maybe_sig ty'
+ | needs_kind_sig
+ = let full_kind = typeKind (mkTyConApp tc tys)
+ full_kind' = synifyType WithinType full_kind
+ in noLoc $ HsKindSig ty' full_kind'
+ | otherwise = ty'
+
+ needs_kind_sig :: Bool
+ needs_kind_sig
+ | GT <- compareLength tys binders
+ = False
+ | otherwise
+ = let (dropped_binders, remaining_binders)
+ = splitAtList tys binders
+ result_kind = mkTyConKind remaining_binders res_kind
+ result_vars = tyCoVarsOfType result_kind
+ dropped_vars = fvVarSet $
+ mapUnionFV injectiveVarsOfBinder dropped_binders
+
+ in not (subVarSet result_vars dropped_vars)
+
synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
synifyType _ (AppTy t1 t2) = let
s1 = synifyType WithinType t1
@@ -430,7 +497,7 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
synifyType s (CastTy t _) = synifyType s t
synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
-synifyPatSynType :: PatSyn -> LHsType Name
+synifyPatSynType :: PatSyn -> LHsType GhcRn
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]
@@ -450,17 +517,16 @@ synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
-synifyKindSig :: Kind -> LHsKind Name
+synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig k = synifyType WithinType k
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
- , ihdKinds = map (unLoc . synifyType WithinType) ks
- , ihdTypes = map (unLoc . synifyType WithinType) ts
+ , ihdTypes = map unLoc annot_ts
, ihdInstType = ClassInst
{ clsiCtx = map (unLoc . synifyType WithinType) preds
- , clsiTyVars = synifyTyVars $ classTyVars cls
+ , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
(Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
@@ -468,24 +534,48 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
}
}
where
- (ks,ts) = partitionInvisibles (classTyCon cls) id types
+ cls_tycon = classTyCon cls
+ ts = filterOutInvisibleTypes cls_tycon types
+ ts' = map (synifyType WithinType) ts
+ annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+ is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
-- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
+synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
synifyFamInst fi opaque = do
- ityp' <- ityp $ fi_flavor fi
+ ityp' <- ityp fam_flavor
return InstHead
{ ihdClsName = fi_fam fi
- , ihdKinds = synifyTypes ks
- , ihdTypes = synifyTypes ts
+ , ihdTypes = map unLoc annot_ts
, ihdInstType = ityp'
}
where
ityp SynFamilyInst | opaque = return $ TypeInst Nothing
ityp SynFamilyInst =
- return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+ return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
- (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
- synifyTypes = map (unLoc. synifyType WithinType)
+ fam_tc = famInstTyCon fi
+ fam_flavor = fi_flavor fi
+ fam_lhs = fi_tys fi
+ fam_rhs = fi_rhs fi
+
+ eta_expanded_lhs
+ -- eta-expand lhs types, because sometimes data/newtype
+ -- instances are eta-reduced; See Trac #9692
+ -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC
+ | DataFamilyInst rep_tc <- fam_flavor
+ = let (_, rep_tc_args) = splitTyConApp fam_rhs
+ etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc
+ etad_tys = mkTyVarTys etad_tyvars
+ eta_exp_lhs = fam_lhs `chkAppend` etad_tys
+ in eta_exp_lhs
+ | otherwise
+ = fam_lhs
+
+ ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
+ synifyTypes = map (synifyType WithinType)
+ ts' = synifyTypes ts
+ annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
+ is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 02867833..a1009c1f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -43,7 +43,7 @@ isConSym :: OccName -> Bool
isConSym = isLexConSym . occNameFS
-getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder :: HsDecl name -> [IdP name]
getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
case collectHsBindBinders d of
@@ -59,21 +59,22 @@ getMainDeclBinder _ = []
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
+getInstLoc (DataFamInstD (DataFamInstDecl
+ { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
getInstLoc (TyFamInstD (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
- { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l
+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
-- but only one of the names is exported and we have to change the
-- type signature to only include the exported names.
-filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name)
filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
-filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
+filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name)
filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p (FixSig (FixitySig ns ty)) =
@@ -99,10 +100,10 @@ ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
ifTrueJust False = const Nothing
-sigName :: LSig name -> [name]
+sigName :: LSig name -> [IdP name]
sigName (L _ sig) = sigNameNoLoc sig
-sigNameNoLoc :: Sig name -> [name]
+sigNameNoLoc :: Sig name -> [IdP name]
sigNameNoLoc (TypeSig ns _) = map unLoc ns
sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
sigNameNoLoc (PatSynSig ns _) = map unLoc ns
@@ -128,7 +129,7 @@ isValD (ValD _) = True
isValD _ = False
-declATs :: HsDecl a -> [a]
+declATs :: HsDecl a -> [IdP a]
declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
@@ -164,7 +165,7 @@ reL = L undefined
-------------------------------------------------------------------------------
-instance NamedThing (TyClDecl Name) where
+instance NamedThing (TyClDecl GhcRn) where
getName = tcdName
-------------------------------------------------------------------------------
@@ -176,14 +177,14 @@ class Parent a where
children :: a -> [Name]
-instance Parent (ConDecl Name) where
+instance Parent (ConDecl GhcRn) where
children con =
case getConDetails con of
RecCon fields -> map (selectorFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
-instance Parent (TyClDecl Name) where
+instance Parent (TyClDecl GhcRn) where
children d
| isDataDecl d = map unL $ concatMap (getConNames . unL)
$ (dd_cons . tcdDataDefn) $ d
@@ -198,12 +199,12 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name])
family = getName &&& children
-familyConDecl :: ConDecl Name -> [(Name, [Name])]
+familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
-families :: TyClDecl Name -> [(Name, [Name])]
+families :: TyClDecl GhcRn -> [(Name, [Name])]
families d
| isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
| isClassDecl d = [family d]
@@ -211,12 +212,12 @@ families d
-- | A mapping from child to parent
-parentMap :: TyClDecl Name -> [(Name, Name)]
+parentMap :: TyClDecl GhcRn -> [(Name, Name)]
parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-- | The parents of a subordinate in a declaration
-parents :: Name -> HsDecl Name -> [Name]
+parents :: Name -> HsDecl GhcRn -> [Name]
parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
parents _ _ = []
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 25755cff..20689a8f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -122,11 +122,7 @@ createIfaces0 verbosity modules flags instIfaceMap =
-- resulting ModSummaries.
(if useTempDir then withTempOutputDir else id) $ do
modGraph <- depAnalysis
- if needsTemplateHaskell modGraph then do
- modGraph' <- enableCompilation modGraph
- createIfaces verbosity flags instIfaceMap modGraph'
- else
- createIfaces verbosity flags instIfaceMap modGraph
+ createIfaces verbosity flags instIfaceMap modGraph
where
useTempDir :: Bool
@@ -149,17 +145,6 @@ createIfaces0 verbosity modules flags instIfaceMap =
depanal [] False
- enableCompilation :: ModuleGraph -> Ghc ModuleGraph
- enableCompilation modGraph = do
- let enableComp d = let platform = targetPlatform d
- in d { hscTarget = defaultObjectTarget platform }
- modifySessionDynFlags enableComp
- -- We need to update the DynFlags of the ModSummaries as well.
- let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
- let modGraph' = map upd modGraph
- return modGraph'
-
-
createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
createIfaces verbosity flags instIfaceMap mods = do
let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
@@ -194,7 +179,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
, expItemMbDoc = (Documentation Nothing _, _)
} <- ifaceExportItems interface ]
where
- formatName :: SrcSpan -> HsDecl Name -> String
+ formatName :: SrcSpan -> HsDecl GhcRn -> String
formatName loc n = p (getMainDeclBinder n) ++ case loc of
RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
_ -> ""
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index a2cdb752..2231ce7e 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -67,7 +68,7 @@ attachInstances expInfo ifaces instIfaceMap = do
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]
+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
[ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
@@ -82,8 +83,8 @@ attachToExportItem
-> Interface
-> IfaceMap
-> InstIfaceMap
- -> ExportItem Name
- -> Ghc (ExportItem Name)
+ -> ExportItem GhcRn
+ -> Ghc (ExportItem GhcRn)
attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
@@ -117,12 +118,12 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
where
attachFixities e@ExportDecl{ expItemDecl = L _ d
, expItemPats = patsyns
+ , expItemSubDocs = subDocs
} = e { expItemFixities =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
- , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]
- , n' <- n : (subs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , n' <- n : (map fst subDocs ++ patsyn_names)
+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 87cdb01f..9bf21e52 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -30,6 +31,7 @@ import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
+import Data.Bifunctor
import Data.Bitraversable
import qualified Data.ByteString as BS
import qualified Data.Map as M
@@ -43,9 +45,12 @@ import Control.Exception (evaluate)
import Control.Monad
import Data.Traversable
+import Avail hiding (avail)
+import qualified Avail
import qualified Packages
import qualified Module
import qualified SrcLoc
+import ConLike (ConLike(..))
import GHC
import HscTypes
import Name
@@ -58,6 +63,7 @@ import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( getConDetails )
+
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
@@ -82,47 +88,36 @@ createInterface tm flags modMap instIfaceMap = do
(TcGblEnv { tcg_rdr_env = gre
, tcg_warns = warnings
- , tcg_patsyns = patsyns
+ , tcg_exports = all_exports
}, md) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
- (group_, mayExports, mayDocHeader) <-
+ (group_, imports, mayExports, mayDocHeader) <-
case renamedSource tm of
Nothing -> do
liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
- return (emptyRnGroup, Nothing, Nothing)
- Just (x, _, y, z) -> return (x, y, z)
+ return (emptyRnGroup, [], Nothing, Nothing)
+ Just x -> return x
- opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
- let opts
- | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
- | otherwise = opts0
+ opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
-- Process the top-level module header documentation.
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
- exports0 = fmap (reverse . map unLoc) mayExports
+ exports0 = fmap (reverse . map (first unLoc)) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
- localBundledPatSyns :: Map Name [Name]
- localBundledPatSyns =
- case exports of
- Nothing -> M.empty
- Just ies ->
- M.map (nubByName id) $
- M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)
- | IEThingWith (L _ ty_name) _ exported _ <- ies
- , let bundled_patsyns =
- filter is_patsyn (map (ieWrappedName . unLoc) exported)
- , not (null bundled_patsyns)
- ]
- where
- is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))
+ unrestrictedImportedMods
+ -- module re-exports are only possible with
+ -- explicit export list
+ | Just _ <- exports
+ = unrestrictedModuleImports (map unLoc imports)
+ | otherwise = M.empty
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
@@ -134,15 +129,16 @@ createInterface tm flags modMap instIfaceMap = do
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
- maps@(!docMap, !argMap, !subMap, !declMap, _) <-
+ maps@(!docMap, !argMap, !declMap, _) <-
liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-- The MAIN functionality: compute the export items which will
-- each be the actual documentation of this module.
- exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
- maps localBundledPatSyns fixMap splices exports instIfaceMap dflags
+ exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre
+ exportedNames decls maps fixMap unrestrictedImportedMods
+ splices exports all_exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -183,8 +179,6 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceExports = exportedNames
, ifaceVisibleExports = visibleNames
, ifaceDeclMap = declMap
- , ifaceBundledPatSynMap = localBundledPatSyns
- , ifaceSubMap = subMap
, ifaceFixMap = fixMap
, ifaceModuleAliases = aliases
, ifaceInstances = instances
@@ -230,6 +224,41 @@ mkAliasMap dflags mRenamedSource =
alias))
impDecls
+-- We want to know which modules are imported without any qualification. This
+-- way we can display module reexports more compactly. This mapping also looks
+-- through aliases:
+--
+-- module M (module X) where
+-- import M1 as X
+-- import M2 as X
+--
+-- With our mapping we know that we can display exported modules M1 and M2.
+--
+unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName]
+unrestrictedModuleImports idecls =
+ M.map (map (unLoc . ideclName))
+ $ M.filter (all isInteresting) impModMap
+ where
+ impModMap =
+ M.fromListWith (++) (concatMap moduleMapping idecls)
+
+ moduleMapping idecl =
+ concat [ [ (unLoc (ideclName idecl), [idecl]) ]
+ , [ (unLoc mod_name, [idecl])
+ | Just mod_name <- [ideclAs idecl]
+ ]
+ ]
+
+ isInteresting idecl =
+ case ideclHiding idecl of
+ -- i) no subset selected
+ Nothing -> True
+ -- ii) an import with a hiding clause
+ -- without any names
+ Just (True, L _ []) -> True
+ -- iii) any other case of qualification
+ _ -> False
+
-- Similar to GHC.lookupModule
-- ezyang: Not really...
lookupModuleDyn ::
@@ -288,10 +317,13 @@ mkDocOpts mbOpts flags mdl = do
hm <- if Flag_HideModule (moduleString mdl) `elem` flags
then return $ OptHide : opts
else return opts
- if Flag_ShowExtensions (moduleString mdl) `elem` flags
- then return $ OptShowExtensions : hm
- else return hm
-
+ ie <- if Flag_IgnoreAllExports `elem` flags
+ then return $ OptIgnoreExports : hm
+ else return hm
+ se <- if Flag_ShowExtensions (moduleString mdl) `elem` flags
+ then return $ OptShowExtensions : ie
+ else return ie
+ return se
parseOption :: String -> ErrMsgM (Maybe DocOption)
parseOption "hide" = return (Just OptHide)
@@ -307,7 +339,7 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
-type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
+type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap)
-- | Create 'Maps' by looping through the declarations. For each declaration,
-- find its names, its subordinates, and its doc strings. Process doc strings
@@ -315,14 +347,13 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Name]
- -> [(LHsDecl Name, [HsDocString])]
+ -> [(LHsDecl GhcRn, [HsDocString])]
-> ErrMsgM Maps
mkMaps dflags gre instances decls = do
- (a, b, c, d) <- unzip4 <$> traverse mappings decls
+ (a, b, c) <- unzip3 <$> traverse mappings decls
pure ( f' (map (nubByName fst) a)
, f (filterMapping (not . M.null) b)
, f (filterMapping (not . null) c)
- , f (filterMapping (not . null) d)
, instanceMap
)
where
@@ -335,11 +366,10 @@ mkMaps dflags gre instances decls = do
filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
filterMapping p = map (filter (p . snd))
- mappings :: (LHsDecl Name, [HsDocString])
+ mappings :: (LHsDecl GhcRn, [HsDocString])
-> ErrMsgM ( [(Name, MDoc Name)]
, [(Name, Map Int (MDoc Name))]
- , [(Name, [Name])]
- , [(Name, [LHsDecl Name])]
+ , [(Name, [LHsDecl GhcRn])]
)
mappings (ldecl, docStrs) = do
let L l decl = ldecl
@@ -363,7 +393,6 @@ mkMaps dflags gre instances decls = do
subNs = [ n | (n, _, _) <- subs ]
dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
- sm = [ (n, subNs) | n <- ns ]
cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
seqList ns `seq`
@@ -371,12 +400,12 @@ mkMaps dflags gre instances decls = do
doc `seq`
seqList subDocs `seq`
seqList subArgs `seq`
- pure (dm, am, sm, cm)
+ pure (dm, am, cm)
instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
- names :: SrcSpan -> HsDecl Name -> [Name]
+ names :: SrcSpan -> HsDecl GhcRn -> [Name]
names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
@@ -401,15 +430,17 @@ mkMaps dflags gre instances decls = do
-- A subordinate declaration is something like the associate type or data
-- family of a type class.
subordinates :: InstMap
- -> HsDecl Name
+ -> HsDecl GhcRn
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
- DataFamInstDecl { dfid_tycon = L l _
- , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
+ DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_tycon = L l _
+ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
- InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
+ InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))
+ -> dataSubs (feqn_rhs d)
TyClD d | isClassDecl d -> classSubs d
| isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
@@ -417,7 +448,7 @@ subordinates instMap decl = case decl of
classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
- dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
+ dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
@@ -434,7 +465,7 @@ subordinates instMap decl = case decl of
, Just instName <- [M.lookup l instMap] ]
-- | Extract function argument docs from inside types.
-typeDocs :: HsDecl Name -> Map Int HsDocString
+typeDocs :: HsDecl GhcRn -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
@@ -455,7 +486,7 @@ typeDocs d =
-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
-classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
@@ -467,18 +498,18 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
-mkFixMap :: HsGroup Name -> FixMap
+mkFixMap :: HsGroup GhcRn -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
| L _ (FixitySig ns f) <- hs_fixds group_,
L _ n <- ns ]
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup Name -> [LHsDecl Name]
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
mkDecls hs_derivds DerivD group_ ++
@@ -578,57 +609,88 @@ mkExportItems
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name] -- renamed source declarations
+ -> [LHsDecl GhcRn] -- renamed source declarations
-> Maps
- -> Map Name [Name]
-> FixMap
+ -> M.Map ModuleName [ModuleName]
-> [SrcSpan] -- splice locations
- -> Maybe [IE Name]
+ -> Maybe [(IE GhcRn, Avails)]
+ -> Avails -- exported stuff from this module
-> InstIfaceMap
-> DynFlags
- -> ErrMsgGhc [ExportItem Name]
+ -> ErrMsgGhc [ExportItem GhcRn]
mkExportItems
is_sig modMap thisMod semMod warnings gre exportedNames decls
- maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags =
- case optExports of
- Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
+ maps fixMap unrestricted_imp_mods splices exportList allExports
+ instIfaceMap dflags =
+ case exportList of
+ Nothing ->
+ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
+ maps fixMap splices instIfaceMap dflags allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x
- lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t
- lookupExport (IEThingAll (L _ t)) = do
- let name = ieWrappedName t
- pats <- findBundledPatterns name
- declWith pats name
- lookupExport (IEThingWith (L _ t) _ _ _) = do
- let name = ieWrappedName t
- pats <- findBundledPatterns name
- declWith pats name
- lookupExport (IEModuleContents (L _ m)) =
- -- TODO: We could get more accurate reporting here if IEModuleContents
- -- also recorded the actual names that are exported here. We CAN
- -- compute this info using @gre@ but 'moduleExports does not seem to
- -- do so.
- -- NB: Pass in identity module, so we can look it up in index correctly
- moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
- lookupExport (IEGroup lev docStr) = liftErrMsg $ do
+ lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do
doc <- processDocString dflags gre docStr
return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr) = liftErrMsg $ do
+ lookupExport (IEDoc docStr, _) = liftErrMsg $ do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEDocNamed str) = liftErrMsg $
+ lookupExport (IEDocNamed str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
- declWith pats t = do
- r <- findDecl t
+ lookupExport (IEModuleContents (L _ mod_name), _)
+ -- only consider exporting a module if we are sure we
+ -- are really exporting the whole module and not some
+ -- subset. We also look through module aliases here.
+ | Just mods <- M.lookup mod_name unrestricted_imp_mods
+ , not (null mods)
+ = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods
+
+ lookupExport (_, avails) =
+ concat <$> traverse availExport (nubAvails avails)
+
+ availExport avail =
+ availExportItem is_sig modMap thisMod semMod warnings exportedNames
+ maps fixMap splices instIfaceMap dflags avail
+
+availExportItem :: Bool -- is it a signature
+ -> IfaceMap
+ -> Module -- this module
+ -> Module -- semantic module
+ -> WarningMap
+ -> [Name] -- exported names (orig)
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> AvailInfo
+ -> ErrMsgGhc [ExportItem GhcRn]
+availExportItem is_sig modMap thisMod semMod warnings exportedNames
+ maps@(docMap, argMap, declMap, instMap) fixMap splices instIfaceMap
+ dflags availInfo
+ | availName availInfo `notElem` availNamesWithSelectors availInfo = do
+ exportItems <- for (availNamesWithSelectors availInfo)
+ (availExportItem is_sig modMap thisMod semMod
+ warnings exportedNames maps fixMap splices
+ instIfaceMap dflags . Avail.avail)
+ return (concat exportItems)
+ | otherwise = do
+ pats <- findBundledPatterns availInfo
+ declWith availInfo pats
+ where
+ declWith :: AvailInfo
+ -> [(HsDecl GhcRn, DocForDecl Name)]
+ -> ErrMsgGhc [ ExportItem GhcRn ]
+ declWith avail pats = do
+ let t = availName avail
+ r <- findDecl avail
case r of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
@@ -664,15 +726,15 @@ mkExportItems
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
- in return [ mkExportDecl t newDecl pats docs_ ]
+ in return [ mkExportDecl avail newDecl pats docs_ ]
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
- return [ mkExportDecl t
+ return [ mkExportDecl avail
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]
- _ -> return [ mkExportDecl t decl pats docs_ ]
+ _ -> return [ mkExportDecl avail decl pats docs_ ]
-- Declaration from another package
([], _) -> do
@@ -689,33 +751,55 @@ mkExportItems
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
- return [ mkExportDecl t decl pats (noDocForDecl, subs_) ]
+ return [ mkExportDecl avail decl pats (noDocForDecl, subs_) ]
Just iface ->
- return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl avail decl pats (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) ]
_ -> return []
- mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)]
- -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
- mkExportDecl name decl pats (doc, subs) = decl'
+ mkExportDecl :: AvailInfo -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)]
+ -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn
+ mkExportDecl avail decl pats (doc, subs) =
+ ExportDecl {
+ expItemDecl = restrictTo sub_names (extractDecl avail decl)
+ , expItemPats = pats'
+ , expItemMbDoc = doc
+ , expItemSubDocs = subs'
+ , expItemInstances = []
+ , expItemFixities = fixities
+ , expItemSpliced = False
+ }
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False
- subs' = filter (isExported . fst) subs
- pats' = [ d | d@(patsyn_decl, _) <- pats
- , all isExported (getMainDeclBinder patsyn_decl) ]
+ name = availName avail
+ -- all the exported names for this ExportItem
+ exported_names = availNamesWithSelectors avail
+ subs' = [ sub
+ | sub@(sub_name, _) <- subs
+ , sub_name `elem` exported_names
+ ]
+ pats' = [ patsyn
+ | patsyn@(patsyn_decl, _) <- pats
+ , all (`elem` exported_names) (getMainDeclBinder patsyn_decl)
+ ]
sub_names = map fst subs'
- pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]
- fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ]
+ pat_names = [ n
+ | (patsyn_decl, _) <- pats'
+ , n <- getMainDeclBinder patsyn_decl
+ ]
+ fixities = [ (n, f)
+ | n <- name:sub_names ++ pat_names
+ , Just f <- [M.lookup n fixMap]
+ ]
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
- findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
- findDecl n
+ findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl avail
| m == semMod =
case M.lookup n declMap of
- Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+ Just ds -> return (ds, lookupDocs avail warnings docMap argMap)
Nothing
| is_sig -> do
-- OK, so it wasn't in the local declaration map. It could
@@ -732,47 +816,31 @@ mkExportItems
return ([], (noDocForDecl, []))
| Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
, Just ds <- M.lookup n (ifaceDeclMap iface) =
- return (ds, lookupDocs n warnings
+ return (ds, lookupDocs avail warnings
(ifaceDocMap iface)
- (ifaceArgMap iface)
- (ifaceSubMap iface))
+ (ifaceArgMap iface))
| otherwise = return ([], (noDocForDecl, []))
where
+ n = availName avail
m = nameModule n
- findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)]
- findBundledPatterns t =
- let
- m = nameModule t
-
- local_bundled_patsyns =
- M.findWithDefault [] t patSynMap
-
- iface_bundled_patsyns
- | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
- , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)
- = patsyns
-
- | Just iface <- M.lookup m instIfaceMap
- , Just patsyns <- M.lookup t (instBundledPatSynMap iface)
- = patsyns
-
- | otherwise
- = []
-
- patsyn_decls = do
- for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do
- -- call declWith here so we don't have to prepare the pattern synonym for
- -- showing ourselves.
- export_items <- declWith [] patsyn_name
+ findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+ findBundledPatterns avail = do
+ patsyns <- for constructor_names $ \name -> do
+ mtyThing <- liftGhcToErrMsgGhc (lookupName name)
+ case mtyThing of
+ Just (AConLike PatSynCon{}) -> do
+ export_items <- declWith (Avail.avail name) []
pure [ (unLoc patsyn_decl, patsyn_doc)
| ExportDecl {
expItemDecl = patsyn_decl
, expItemMbDoc = patsyn_doc
} <- export_items
]
-
- in concat <$> patsyn_decls
+ _ -> pure []
+ pure (concat patsyns)
+ where
+ constructor_names = filter isDataConName (availNames avail)
-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
-- we can actually find in the 'IfaceMap'.
@@ -781,7 +849,7 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
case mayTyThing of
@@ -803,7 +871,7 @@ hiDecl dflags t = do
-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
-- declaration and use it instead - 'nLoc' here.
hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
- -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+ -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)
hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
@@ -817,48 +885,29 @@ hiValExportItem dflags name nLoc doc splice fixity = do
-- | Lookup docs for a declaration from maps.
-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap
+lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs n warnings docMap argMap subMap =
+lookupDocs avail warnings docMap argMap =
+ let n = availName avail in
let lookupArgDoc x = M.findWithDefault M.empty x argMap in
let doc = (lookupDoc n, lookupArgDoc n) in
- let subs = M.findWithDefault [] n subMap in
- let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s))
+ | s <- availNamesWithSelectors avail
+ , s /= n ] in
(doc, subDocs)
where
lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
--- | Return all export items produced by an exported module. That is, we're
--- interested in the exports produced by \"module B\" in such a scenario:
---
--- > module A (module B) where
--- > import B (...) hiding (...)
---
--- There are three different cases to consider:
---
--- 1) B is hidden, in which case we return all its exports that are in scope in A.
--- 2) B is visible, but not all its exports are in scope in A, in which case we
--- only return those that are.
--- 3) B is visible and all its exports are in scope, in which case we return
--- a single 'ExportModule' item.
-moduleExports :: Module -- ^ Module A (identity, NOT semantic)
- -> ModuleName -- ^ The real name of B, the exported module
- -> DynFlags -- ^ The flags used when typechecking A
- -> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment used for A
- -> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the renamed declarations in A
- -> IfaceMap -- ^ Already created interfaces
- -> InstIfaceMap -- ^ Interfaces in other packages
- -> Maps
- -> FixMap
- -> [SrcSpan] -- ^ Locations of all TH splices
- -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
- | expMod == moduleName thisMod
- = fullModuleContents dflags warnings gre maps fixMap splices decls
- | otherwise =
+-- | Export the given module as `ExportModule`. We are not concerned with the
+-- single export items of the given module.
+moduleExport :: Module -- ^ Module A (identity, NOT semantic)
+ -> DynFlags -- ^ The flags used when typechecking A
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> ModuleName -- ^ The exported module
+ -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items
+moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- NB: we constructed the identity module when looking up in
-- the IfaceMap.
case M.lookup m ifaceMap of
@@ -879,7 +928,6 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
m = mkModule unitId expMod -- Identity module!
unitId = moduleUnitId thisMod
-
-- Note [1]:
------------
-- It is unnecessary to document a subordinate by itself at the top level if
@@ -900,87 +948,35 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- | Simplified variant of 'mkExportItems', where we can assume that
-- every locally defined declaration is exported; thus, we just
-- zip through the renamed declarations.
-fullModuleContents :: DynFlags
+
+fullModuleContents :: Bool -- is it a signature
+ -> IfaceMap
+ -> Module -- this module
+ -> Module -- semantic module
-> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment
+ -> [Name] -- exported names (orig)
-> Maps
-> FixMap
- -> [SrcSpan] -- ^ Locations of all TH splices
- -> [LHsDecl Name] -- ^ All the renamed declarations
- -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
- liftM catMaybes $ mapM mkExportItem (expandSigDecls decls)
- where
- -- A type signature can have multiple names, like:
- -- foo, bar :: Types..
- --
- -- We go through the list of declarations and expand type signatures, so
- -- that every type signature has exactly one name!
- expandSigDecls :: [LHsDecl name] -> [LHsDecl name]
- expandSigDecls = concatMap f
- where
- f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ]
-
- -- also expand type signatures for class methods
- f (L l (TyClD cls@ClassDecl{})) =
- [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ]
- f x = [x]
-
- expandLSig :: LSig name -> [LSig name]
- expandLSig (L l sig) = [ L l s | s <- expandSig sig ]
-
- expandSig :: Sig name -> [Sig name]
- expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ]
- expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]
- expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ]
- expandSig x = [x]
-
- mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
- mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- doc <- liftErrMsg (processDocString dflags gre docStr)
- return . Just . ExportGroup lev "" $ doc
- mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- doc <- liftErrMsg (processDocStringParas dflags gre docStr)
- return . Just . ExportDoc $ doc
- mkExportItem (L l (ValD d))
- | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
- -- Top-level binding without type signature.
- let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap)
- | otherwise = return Nothing
- mkExportItem decl@(L l (InstD d))
- | Just name <- M.lookup (getInstLoc d) instMap =
- expInst decl l name
- mkExportItem decl@(L l (DerivD {}))
- | Just name <- M.lookup l instMap =
- expInst decl l name
- mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
- mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
- expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
- mkExportItem decl@(L l d)
- | name:_ <- getMainDeclBinder d = expDecl decl l name
- | otherwise = return Nothing
-
- fixities name subs = [ (n,f) | n <- name : map fst subs
- , Just f <- [M.lookup n fixMap] ]
-
- expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
- where (doc, subs) = lookupDocs name warnings docMap argMap subMap
-
- expInst decl l name =
- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
-
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> Avails
+ -> ErrMsgGhc [ExportItem GhcRn]
+fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
+ maps fixMap splices instIfaceMap dflags avails =
+
+ concat <$> traverse (availExportItem is_sig modMap thisMod
+ semMod warnings exportedNames maps fixMap
+ splices instIfaceMap dflags) avails
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
-extractDecl name decl
- | name `elem` getMainDeclBinder (unLoc decl) = decl
- | otherwise =
+extractDecl :: AvailInfo -> LHsDecl GhcRn -> LHsDecl GhcRn
+extractDecl avail decl
+ | availName avail `elem` getMainDeclBinder (unLoc decl) = decl
+ | [name] <- availNamesWithSelectors avail =
case unLoc decl of
TyClD d@ClassDecl {} ->
let matches = [ lsig
@@ -1003,32 +999,35 @@ extractDecl name decl
in if isDataConName name
then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
- InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsIB { hsib_body = tys }
- , dfid_defn = defn }) ->
+ InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ FamEqn { feqn_tycon = L _ n
+ , feqn_pats = tys
+ , feqn_rhs = defn }}))) ->
SigD <$> extractRecSel name n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
- let matches = [ d | L _ d <- insts
- -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
- , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d))
- , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
- , L _ n <- ns
- , selectorFieldOcc n == name
+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+ <- insts
+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
+ , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))
+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
+ , L _ n <- ns
+ , selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl avail (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
+ | otherwise = decl
-extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name
+extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
case filter matches cons of
[] -> error "extractPatternSyn: constructor pattern not found"
con:_ -> extract <$> con
where
- matches :: LConDecl Name -> Bool
+ matches :: LConDecl GhcRn -> Bool
matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
- extract :: ConDecl Name -> Sig Name
+ extract :: ConDecl GhcRn -> Sig GhcRn
extract con =
let args =
case getConDetails con of
@@ -1050,8 +1049,8 @@ extractPatternSyn nm t tvs cons =
| ConDeclGADT{} <- con = hsib_body $ con_type con
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
- -> LSig Name
+extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
+ -> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
@@ -1060,7 +1059,7 @@ extractRecSel nm t tvs (L _ con : rest) =
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
- matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+ matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
, L l n <- ns, selectorFieldOcc n == nm ]
data_ty
@@ -1069,15 +1068,15 @@ extractRecSel nm t tvs (L _ con : rest) =
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
+pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems = filter hasDoc
where
hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
-mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
-mkVisibleNames (_, _, _, _, instMap) exports opts
+mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name]
+mkVisibleNames (_, _, _, instMap) exports opts
| OptHide `elem` opts = []
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
@@ -1122,7 +1121,7 @@ mkTokenizedSrc ms src = do
return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))
-- | Find a stand-alone documentation comment by its name.
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
+findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
where
search [] = do
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 9a569204..636d3e19 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -37,8 +37,6 @@ jsonInstalledInterface InstalledInterface{..} = jsonObject properties
, ("exports" , jsonArray (map jsonName instExports))
, ("visible_exports" , jsonArray (map jsonName instVisibleExports))
, ("options" , jsonArray (map (jsonString . show) instOptions))
- , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap)
- , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap)
, ("fix_map" , jsonMap nameStableString jsonFixity instFixMap)
]
@@ -106,4 +104,3 @@ jsonInt = JSInt
jsonBool :: Bool -> JsonDoc
jsonBool = JSBool
-
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index a38e7667..75b2f223 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -31,6 +31,7 @@ import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
+import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
@@ -70,7 +71,7 @@ processModuleHeader dflags gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 5820c61e..7023a908 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -147,7 +147,7 @@ renameL :: Located Name -> RnM (Located DocName)
renameL = mapM rename
-renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem
@@ -172,22 +172,22 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
-renameLType :: LHsType Name -> RnM (LHsType DocName)
+renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
-renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
+renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType
-renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
+renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
renameLSigWcType = renameWc (renameImplicit renameLType)
-renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
renameLKind = renameLType
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
-renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)
+renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
renameFamilyResultSig (L loc NoSig)
= return (L loc NoSig)
renameFamilyResultSig (L loc (KindSig ki))
@@ -197,17 +197,17 @@ renameFamilyResultSig (L loc (TyVarSig bndr))
= do { bndr' <- renameLTyVarBndr bndr
; return (L loc (TyVarSig bndr')) }
-renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)
+renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
= do { lhs' <- renameL lhs
; rhs' <- mapM renameL rhs
; return (L loc (InjectivityAnn lhs' rhs')) }
-renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)
- -> RnM (Maybe (LInjectivityAnn DocName))
+renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
+ -> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
-renameType :: HsType Name -> RnM (HsType DocName)
+renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
@@ -268,13 +268,13 @@ renameType t = case t of
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
HsAppsTy _ -> error "renameType: HsAppsTy"
-renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
+renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr 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)
+renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar (L l n)))
= do { n' <- rename n
; return (L loc (UserTyVar (L l n'))) }
@@ -283,18 +283,17 @@ renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
; kind' <- renameLKind kind
; return (L loc (KindedTyVar (L lv n') kind')) }
-renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
+renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
+renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)
renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
-renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
- kinds <- mapM renameType ihdKinds
types <- mapM renameType ihdTypes
itype <- case ihdInstType of
ClassInst { .. } -> ClassInst
@@ -306,21 +305,20 @@ renameInstHead InstHead {..} = do
DataInst dd -> DataInst <$> renameTyClD dd
return InstHead
{ ihdClsName = cname
- , ihdKinds = kinds
, ihdTypes = types
, ihdInstType = itype
}
-renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
+renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
-renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)]
+renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)]
renamePats = mapM
(\(d,doc) -> do { d' <- renameDecl d
; doc' <- renameDocForDecl doc
; return (d',doc')})
-renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
+renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
TyClD d -> do
d' <- renameTyClD d
@@ -339,10 +337,10 @@ renameDecl decl = case decl of
return (DerivD d')
_ -> error "renameDecl"
-renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
renameLThing fn (L loc x) = return . L loc =<< fn x
-renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
+renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI)
renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
@@ -384,7 +382,7 @@ renameTyClD d = case d of
renameLSig (L loc sig) = return . L loc =<< renameSig sig
-renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdTyVars = ltyvars
, fdFixity = fixity
@@ -402,8 +400,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdInjectivityAnn = injectivity' })
-renamePseudoFamilyDecl :: PseudoFamilyDecl Name
- -> RnM (PseudoFamilyDecl DocName)
+renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
+ -> RnM (PseudoFamilyDecl DocNameI)
renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<$> renameFamilyInfo pfdInfo
<*> renameL pfdLName
@@ -411,14 +409,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
<*> renameFamilyResultSig pfdKindSig
-renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
renameFamilyInfo (ClosedTypeFamily eqns)
- = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns
+ = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns
; return $ ClosedTypeFamily eqns' }
-renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
lcontext' <- renameLContext lcontext
@@ -429,7 +427,7 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = noLoc [] })
-renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_doc = mbldoc }) = do
@@ -460,19 +458,19 @@ renameCon decl@(ConDeclGADT { con_names = lnames
return (decl { con_names = lnames'
, con_type = lty', con_doc = mbldoc' })
-renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
+renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
return $ L l (ConDeclField names' t' doc')
-renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)
+renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc lbl sel)) = do
sel' <- rename sel
return $ L l (FieldOcc lbl sel')
-renameSig :: Sig Name -> RnM (Sig DocName)
+renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
TypeSig lnames ltype -> do
lnames' <- mapM renameL lnames
@@ -496,7 +494,7 @@ renameSig sig = case sig of
_ -> error "expected TypeSig"
-renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
+renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport lname ltype co x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
@@ -507,7 +505,7 @@ renameForD (ForeignExport lname ltype co x) = do
return (ForeignExport lname' ltype' co x)
-renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
+renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
return (ClsInstD { cid_inst = d' })
@@ -518,7 +516,7 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
return (DataFamInstD { dfid_inst = d' })
-renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)
+renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
@@ -527,7 +525,7 @@ renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode })
-renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
, cid_datafam_insts = lADTs }) = do
@@ -540,45 +538,60 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
-renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
+renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
- = do { eqn' <- renameLTyFamInstEqn eqn
- ; return (TyFamInstDecl { tfid_eqn = eqn'
- , tfid_fvs = placeHolderNames }) }
-
-renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs }))
- = do { tc' <- renameL tc
- ; pats' <- renameImplicit (mapM renameLType) pats
- ; rhs' <- renameLType rhs
- ; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = pats'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' })) }
+ = do { eqn' <- renameTyFamInstEqn eqn
+ ; return (TyFamInstDecl { tfid_eqn = eqn' }) }
-renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs }))
+renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
+renameTyFamInstEqn eqn
+ = renameImplicit rename_ty_fam_eqn eqn
+ where
+ rename_ty_fam_eqn
+ :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
+ -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
+ , feqn_fixity = fixity, feqn_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType pats
+ ; rhs' <- renameLType rhs
+ ; return (FamEqn { feqn_tycon = tc'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }) }
+
+renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
+renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
+ , feqn_fixity = fixity, feqn_rhs = rhs }))
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
- ; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = tvs'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' })) }
-
-renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn })
- = do { tc' <- renameL tc
- ; pats' <- renameImplicit (mapM renameLType) pats
- ; defn' <- renameDataDefn defn
- ; return (DataFamInstDecl { dfid_tycon = tc'
- , dfid_pats = pats'
- , dfid_fixity = fixity
- , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+ ; return (L loc (FamEqn { feqn_tycon = tc'
+ , feqn_pats = tvs'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' })) }
+
+renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
+renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
+ = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
+ ; return (DataFamInstDecl { dfid_eqn = eqn' }) }
+ where
+ rename_data_fam_eqn
+ :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
+ -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
+ , feqn_fixity = fixity, feqn_rhs = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType pats
+ ; defn' <- renameDataDefn defn
+ ; return (FamEqn { feqn_tycon = tc'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = defn' }) }
renameImplicit :: (in_thing -> RnM out_thing)
- -> HsImplicitBndrs Name in_thing
- -> RnM (HsImplicitBndrs DocName out_thing)
+ -> HsImplicitBndrs GhcRn in_thing
+ -> RnM (HsImplicitBndrs DocNameI out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
@@ -586,21 +599,21 @@ renameImplicit rn_thing (HsIB { hsib_body = thing })
, hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
- -> HsWildCardBndrs Name in_thing
- -> RnM (HsWildCardBndrs DocName out_thing)
+ -> HsWildCardBndrs GhcRn in_thing
+ -> RnM (HsWildCardBndrs DocNameI out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
, hswc_wcs = PlaceHolder }) }
-renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
+renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n) = do
inst' <- renameInstHead inst
n' <- rename n
idoc' <- mapM renameDoc idoc
return (inst', idoc',L l n')
-renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
ExportGroup lev id_ doc -> do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 84168151..6d2888d3 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -28,13 +28,19 @@ import Data.Set (Set)
import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
-specialize :: forall name a. (Ord name, DataId name, NamedThing name)
+specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
- => [(name, HsType name)] -> a -> a
+ => [(IdP name, HsType name)] -> a -> a
specialize specs = go
where
go :: forall x. Data x => x -> x
- go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+ go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+
+ strip_kind_sig :: HsType name -> HsType name
+ strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig typ = typ
+
+ specialize_ty_var :: HsType name -> HsType name
specialize_ty_var (HsTyVar _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var typ = typ
@@ -48,7 +54,7 @@ specialize specs = go
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name)
+specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
=> LHsQTyVars name -> [HsType name]
-> a -> a
@@ -60,14 +66,14 @@ specializeTyVarBndrs bndrs typs =
bname (KindedTyVar (L _ name) _) = name
-specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name)
+specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> PseudoFamilyDecl name
-> PseudoFamilyDecl name
specializePseudoFamilyDecl bndrs typs decl =
decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name)
+specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> Sig name
-> Sig name
@@ -84,7 +90,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name)
+specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> InstHead name -> InstHead name
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
@@ -104,11 +110,11 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing name, DataId name)
+sugar :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> HsType name
sugar = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
@@ -117,7 +123,7 @@ sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
sugarLists typ = typ
-sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
sugarTuples typ =
aux [] typ
where
@@ -134,7 +140,7 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing name => HsType name -> HsType name
+sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
@@ -202,7 +208,7 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing name, DataId name)
+freeVariables :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
@@ -225,8 +231,8 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: (Eq name, DataId name, SetName name)
- => Set Name -> HsType name -> HsType name
+rename :: (Eq (IdP name), DataId name, SetName (IdP name))
+ => Set Name-> HsType name -> HsType name
rename fv typ = evalState (renameType typ) env
where
env = RenameEnv
@@ -246,8 +252,8 @@ data RenameEnv name = RenameEnv
}
-renameType :: (Eq name, SetName name)
- => HsType name -> Rename name (HsType name)
+renameType :: (Eq (IdP name), SetName (IdP name))
+ => HsType name -> Rename (IdP name) (HsType name)
renameType (HsForAllTy bndrs lt) =
HsForAllTy
<$> mapM (located renameBinder) bndrs
@@ -283,23 +289,22 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
-renameLType :: (Eq name, SetName name)
- => LHsType name -> Rename name (LHsType name)
+renameLType :: (Eq (IdP name), SetName (IdP name))
+ => LHsType name -> Rename (IdP name) (LHsType name)
renameLType = located renameType
-renameLTypes :: (Eq name, SetName name)
- => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: (Eq (IdP name), SetName (IdP name))
+ => [LHsType name] -> Rename (IdP name) [LHsType name]
renameLTypes = mapM renameLType
-renameContext :: (Eq name, SetName name)
- => HsContext name -> Rename name (HsContext name)
+renameContext :: (Eq (IdP name), SetName (IdP name))
+ => HsContext name -> Rename (IdP name) (HsContext name)
renameContext = renameLTypes
-
-renameBinder :: (Eq name, SetName name)
- => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameBinder :: (Eq (IdP name), SetName (IdP name))
+ => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
renameBinder (KindedTyVar lname lkind) =
KindedTyVar <$> located renameName lname <*> located renameType lkind
@@ -333,9 +338,7 @@ freshName name = do
takenNames :: NamedThing name => Rename name (Set NameRep)
takenNames = do
RenameEnv { .. } <- get
- return $ headReps rneHeadFVs `Set.union`
- rneSigFVs `Set.union`
- ctxElems rneCtx
+ return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]
where
headReps = Set.fromList . Map.keys
ctxElems = Set.fromList . map getNameRep . Map.elems
@@ -359,6 +362,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-tyVarName :: HsTyVarBndr name -> name
+tyVarName :: HsTyVarBndr name -> IdP name
tyVarName (UserTyVar name) = unLoc name
tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 31881c76..76bcb4ae 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)
-binaryInterfaceVersion = 31
+#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
+binaryInterfaceVersion = 32
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -373,7 +373,7 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
put_ bh (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap patSynMap fixMap) = do
+ exps visExps opts fixMap) = do
put_ bh modu
put_ bh is_sig
put_ bh info
@@ -381,8 +381,6 @@ instance Binary InstalledInterface where
put_ bh exps
put_ bh visExps
put_ bh opts
- put_ bh subMap
- put_ bh patSynMap
put_ bh fixMap
get bh = do
@@ -393,12 +391,9 @@ instance Binary InstalledInterface where
exps <- get bh
visExps <- get bh
opts <- get bh
- subMap <- get bh
- patSynMap <- get bh
fixMap <- get bh
-
return (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap patSynMap fixMap)
+ exps visExps opts fixMap)
instance Binary DocOption where
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 724f59bc..b4cdc343 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.PlaceHolder
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -59,7 +57,7 @@ type InstIfaceMap = Map Module InstalledInterface -- TODO: rename
type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
-type DeclMap = Map Name [LHsDecl Name]
+type DeclMap = Map Name [LHsDecl GhcRn]
type InstMap = Map SrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -101,10 +99,7 @@ data Interface = Interface
-- | Declarations originating from the module. Excludes declarations without
-- names (instances and stand-alone documentation comments). Includes
-- names of subordinate declarations mapped to their parent declarations.
- , ifaceDeclMap :: !(Map Name [LHsDecl Name])
-
- -- | Bundled pattern synonym declarations for specific types.
- , ifaceBundledPatSynMap :: !(Map Name [Name])
+ , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn])
-- | Documentation of declarations originating from the module (including
-- subordinates).
@@ -116,11 +111,10 @@ data Interface = Interface
, ifaceRnDocMap :: !(DocMap DocName)
, ifaceRnArgMap :: !(ArgMap DocName)
- , ifaceSubMap :: !(Map Name [Name])
, ifaceFixMap :: !(Map Name Fixity)
- , ifaceExportItems :: ![ExportItem Name]
- , ifaceRnExportItems :: ![ExportItem DocName]
+ , ifaceExportItems :: ![ExportItem GhcRn]
+ , ifaceRnExportItems :: ![ExportItem DocNameI]
-- | All names exported by the module.
, ifaceExports :: ![Name]
@@ -138,8 +132,8 @@ data Interface = Interface
, ifaceFamInstances :: ![FamInst]
-- | Orphan instances
- , ifaceOrphanInstances :: ![DocInstance Name]
- , ifaceRnOrphanInstances :: ![DocInstance DocName]
+ , ifaceOrphanInstances :: ![DocInstance GhcRn]
+ , ifaceRnOrphanInstances :: ![DocInstance DocNameI]
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
@@ -186,10 +180,6 @@ data InstalledInterface = InstalledInterface
-- | Haddock options for this module (prune, ignore-exports, etc).
, instOptions :: [DocOption]
- , instSubMap :: Map Name [Name]
-
- , instBundledPatSynMap :: Map Name [Name]
-
, instFixMap :: Map Name Fixity
}
@@ -205,8 +195,6 @@ toInstalledIface interface = InstalledInterface
, instExports = ifaceExports interface
, instVisibleExports = ifaceVisibleExports interface
, instOptions = ifaceOptions interface
- , instSubMap = ifaceSubMap interface
- , instBundledPatSynMap = ifaceBundledPatSynMap interface
, instFixMap = ifaceFixMap interface
}
@@ -225,21 +213,21 @@ data ExportItem name
expItemDecl :: !(LHsDecl name)
-- | Bundled patterns for a data type declaration
- , expItemPats :: ![(HsDecl name, DocForDecl name)]
+ , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]
-- | Maybe a doc comment, and possibly docs for arguments (if this
-- decl is a function or type-synonym).
- , expItemMbDoc :: !(DocForDecl name)
+ , expItemMbDoc :: !(DocForDecl (IdP name))
-- | Subordinate names, possibly with documentation.
- , expItemSubDocs :: ![(name, DocForDecl name)]
+ , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))]
-- | Instances relevant to this declaration, possibly with
-- documentation.
, expItemInstances :: ![DocInstance name]
-- | Fixity decls relevant to this declaration (including subordinates).
- , expItemFixities :: ![(name, Fixity)]
+ , expItemFixities :: ![(IdP name, Fixity)]
-- | Whether the ExportItem is from a TH splice or not, for generating
-- the appropriate type of Source link.
@@ -249,10 +237,10 @@ data ExportItem name
-- | An exported entity for which we have no documentation (perhaps because it
-- resides in another package).
| ExportNoDecl
- { expItemName :: !name
+ { expItemName :: !(IdP name)
-- | Subordinate names.
- , expItemSubs :: ![name]
+ , expItemSubs :: ![IdP name]
}
-- | A section heading.
@@ -265,11 +253,11 @@ data ExportItem name
, expItemSectionId :: !String
-- | Section heading text.
- , expItemSectionText :: !(Doc name)
+ , expItemSectionText :: !(Doc (IdP name))
}
-- | Some documentation.
- | ExportDoc !(MDoc name)
+ | ExportDoc !(MDoc (IdP name))
-- | A cross-reference to another module.
| ExportModule !Module
@@ -309,14 +297,10 @@ data DocName
-- documentation, as far as Haddock knows.
deriving (Eq, Data)
-type instance PostRn DocName NameSet = PlaceHolder
-type instance PostRn DocName Fixity = PlaceHolder
-type instance PostRn DocName Bool = PlaceHolder
-type instance PostRn DocName [Name] = PlaceHolder
+data DocNameI
+
+type instance IdP DocNameI = DocName
-type instance PostTc DocName Kind = PlaceHolder
-type instance PostTc DocName Type = PlaceHolder
-type instance PostTc DocName Coercion = PlaceHolder
instance NamedThing DocName where
getName (Documented name _) = name
@@ -363,7 +347,7 @@ data InstType name
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
-instance (OutputableBndrId a)
+instance (SourceTextX a, OutputableBndrId a)
=> Outputable (InstType a) where
ppr (ClassInst { .. }) = text "ClassInst"
<+> ppr clsiCtx
@@ -382,7 +366,7 @@ instance (OutputableBndrId a)
-- 'PseudoFamilyDecl' type is introduced.
data PseudoFamilyDecl name = PseudoFamilyDecl
{ pfdInfo :: FamilyInfo name
- , pfdLName :: Located name
+ , pfdLName :: Located (IdP name)
, pfdTyVars :: [LHsType name]
, pfdKindSig :: LFamilyResultSig name
}
@@ -404,13 +388,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
-- | An instance head that may have documentation and a source location.
-type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
+type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))
--- | The head of an instance. Consists of a class name, a list of kind
--- parameters, a list of type parameters and an instance type
+-- | The head of an instance. Consists of a class name, a list of type
+-- parameters (which may be annotated with kinds), and an instance type
data InstHead name = InstHead
- { ihdClsName :: name
- , ihdKinds :: [HsType name]
+ { ihdClsName :: IdP name
, ihdTypes :: [HsType name]
, ihdInstType :: InstType name
}
@@ -668,14 +651,14 @@ instance Monad ErrMsgGhc where
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance PostRn DocName NameSet = PlaceHolder
-type instance PostRn DocName Fixity = PlaceHolder
-type instance PostRn DocName Bool = PlaceHolder
-type instance PostRn DocName Name = DocName
-type instance PostRn DocName (Located Name) = Located DocName
-type instance PostRn DocName [Name] = PlaceHolder
-type instance PostRn DocName DocName = DocName
-
-type instance PostTc DocName Kind = PlaceHolder
-type instance PostTc DocName Type = PlaceHolder
-type instance PostTc DocName Coercion = PlaceHolder
+type instance PostRn DocNameI NameSet = PlaceHolder
+type instance PostRn DocNameI Fixity = PlaceHolder
+type instance PostRn DocNameI Bool = PlaceHolder
+type instance PostRn DocNameI Name = DocName
+type instance PostRn DocNameI (Located Name) = Located DocName
+type instance PostRn DocNameI [Name] = PlaceHolder
+type instance PostRn DocNameI DocName = DocName
+
+type instance PostTc DocNameI Kind = PlaceHolder
+type instance PostTc DocNameI Type = PlaceHolder
+type instance PostTc DocNameI Coercion = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 7898bb0b..84f58ab8 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -124,12 +124,12 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
-mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
+mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
-- Dubious, because the implicit binders are empty even
-- though the type might have free varaiables
mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
-addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
+addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
= L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
@@ -147,7 +147,7 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes tvs
= [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
@@ -157,7 +157,7 @@ lHsQTyVarsToTypes tvs
--------------------------------------------------------------------------------
-restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
+restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
TyClD d | isDataDecl d ->
TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
@@ -166,7 +166,7 @@ restrictTo names (L loc decl) = L loc $ case decl of
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
-restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name
+restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
| DataType <- new_or_data
= defn { dd_cons = restrictCons names cons }
@@ -176,7 +176,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
[con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
-restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
+restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
@@ -196,7 +196,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
h98ConDecl c@ConDeclGADT{} = c'
where
(details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)
- c' :: ConDecl Name
+ c' :: ConDecl GhcRn
c' = ConDeclH98
{ con_name = head (con_names c)
, con_qvars = Just $ HsQTvs { hsq_implicit = mempty
@@ -207,18 +207,18 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
, con_doc = con_doc c
}
- field_avail :: LConDeclField Name -> Bool
+ field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField fs _ _))
= all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
field_types flds = [ t | ConDeclField _ t _ <- flds ]
keep _ = Nothing
-restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
+restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
+restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
emptyHsQTvs :: LHsQTyVars Name
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 07:27:42 +0000