From 2067a2d0afa9cef381d26fb7140b67c62f433fc0 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 03:13:10 -0700 Subject: Render signature module tree separately from modules. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Backends/Xhtml.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 9fd55e49..520dafcb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -256,13 +256,20 @@ ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree dflags showPkgs - [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , not (instIsSig iface)] + sig_tree = mkModuleTree dflags showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , instIsSig iface] html = headHtml doctitle Nothing themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ ppPrologue qual doctitle prologue, + ppSignatureTree qual sig_tree, ppModuleTree qual tree ] createDirectoryIfMissing True odir @@ -278,7 +285,13 @@ ppPrologue qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppSignatureTree :: Qualification -> [ModuleTree] -> Html +ppSignatureTree qual ts = + divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts) + + ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree _ [] = mempty ppModuleTree qual ts = divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) @@ -345,6 +358,8 @@ flatModuleTree ifaces = ppHtmlContentsFrame :: FilePath -> String -> Themes -> Maybe String -> [InstalledInterface] -> Bool -> IO () ppHtmlContentsFrame odir doctitle themes maybe_mathjax_url ifaces debug = do + -- TODO: Arguably should split up signatures and modules here too... + -- but who uses frames? Fix this if someone complains. -- ezyang let mods = flatModuleTree ifaces html = headHtml doctitle Nothing themes maybe_mathjax_url +++ -- cgit v1.2.3 From 07b88c5d4e79b87a319fbb08f8ea01dbb41063c1 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 13:48:12 -0700 Subject: Annotate signature docs with (signature) Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 520dafcb..3b2842cc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -513,13 +513,16 @@ ppHtmlModule odir doctitle themes mdl = ifaceMod iface aliases = ifaceModuleAliases iface mdl_str = moduleString mdl + mdl_str_annot = mdl_str ++ if ifaceIsSig iface + then " (signature)" + else "" real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] -- cgit v1.2.3 From 4eb765ca4205c79539d60b7afa9b7e261a4a49fe Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 14:11:25 -0700 Subject: Render help documentation link next to (signature) in title. Signed-off-by: Edward Z. Yang --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 5 +++++ haddock-api/src/Haddock/Backends/Xhtml.hs | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 3ebb14de..f816aeca 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -88,6 +88,11 @@ pre, code, kbd, samp, tt, .src { font-size: 182%; /* 24pt */ } +#module-header .caption sup { + font-size: 70%; + font-weight: normal; +} + .info { font-size: 85%; /* 11pt */ } diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 3b2842cc..10b69a68 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -516,13 +516,17 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" + mdl_str_linked = mdl_str +++ + " (signature" +++ + sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ + ")" real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] @@ -530,6 +534,9 @@ ppHtmlModule odir doctitle themes writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug +signatureDocURL :: String +signatureDocURL = "https://wiki.haskell.org/Module_signature" + ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO () ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do -- cgit v1.2.3 From a0c4790e15a2d3fab8d830eee8fcd639fe6d39c9 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 22 Apr 2017 20:38:26 -0700 Subject: Render (signature) only if it actually is a signature! I forgot a conditional, oops! Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 7b5f9017..0c9abbf2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -486,10 +486,13 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" - mdl_str_linked = mdl_str +++ - " (signature" +++ + mdl_str_linked + | ifaceIsSig iface + = mdl_str +++ " (signature" +++ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ ")" + | otherwise + = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ -- cgit v1.2.3 From 1e1f85d6513b84bac3ae13470900ac7c23e8640e Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 23 May 2017 23:16:32 +0200 Subject: Match new AST as per GHC wip/new-tree-one-param See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow --- haddock-api/src/Haddock/Backends/Hoogle.hs | 24 ++-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 25 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 94 +++++++-------- haddock-api/src/Haddock/Backends/Xhtml.hs | 14 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 134 ++++++++++----------- haddock-api/src/Haddock/Convert.hs | 40 +++--- haddock-api/src/Haddock/GhcUtils.hs | 26 ++-- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 7 +- haddock-api/src/Haddock/Interface/Create.hs | 67 ++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 86 ++++++------- haddock-api/src/Haddock/Interface/Specialize.hs | 54 ++++----- haddock-api/src/Haddock/Types.hs | 66 +++++----- haddock-api/src/Haddock/Utils.hs | 20 +-- 14 files changed, 329 insertions(+), 330 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 86a73c33..86e4ca30 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -85,7 +85,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 @@ -116,7 +116,7 @@ commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport :: DynFlags -> ExportItem GHCR -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs @@ -134,7 +134,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc :: DynFlags -> Sig GHCR -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where @@ -146,17 +146,17 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs ppSigWithDoc _ _ _ = [] -ppSig :: DynFlags -> Sig Name -> [String] +ppSig :: DynFlags -> Sig GHCR -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig :: DynFlags -> [Located Name] -> LHsType GHCR -> 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 GHCR -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where @@ -178,7 +178,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn :: TyFamDefltEqn GHCR -> TyClDecl GHCR tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe , tcdTyVars = tfe_pats tfe @@ -200,10 +200,10 @@ ppInstance dflags x = cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } -ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym :: DynFlags -> TyClDecl GHCR -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData :: DynFlags -> TyClDecl GHCR -> [(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) @@ -224,7 +224,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 GHCR -> [(Name, DocForDecl Name)] -> ConDecl GHCR -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) @@ -257,8 +257,8 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {} name = out dflags $ map unL $ getConNames con -ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] +ppFixity :: DynFlags -> (IdP GHCR, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GHCR)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index b97f0ead..abdcafcc 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -56,13 +56,13 @@ variables = everything (<|>) (var `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.GHCR)) -> 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.GHCR) _) -> pure (sspan, RtkVar name) _ -> empty @@ -72,7 +72,7 @@ types = everything (<|>) 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.GHCR)) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -86,11 +86,11 @@ binds = everything (<|>) (fun `combine` pat `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.GHCR)) -> 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.GHCR)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs @@ -98,11 +98,11 @@ binds = 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.GHCR) _)) -> 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.GHCR)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) @@ -122,20 +122,21 @@ 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.GHCR)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of - (Just cdcl) -> + (Just (cdcl :: GHC.ConDecl GHC.GHCR)) -> map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl Nothing -> empty ins term = case cast term of - (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst + (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GHCR)) + -> pure . tyref $ GHC.dfid_tycon inst (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> pure . tyref $ GHC.tfe_tycon eqn _ -> empty fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.Name) + Just (field :: GHC.ConDeclField GHC.GHCR) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty sig (GHC.L _ (GHC.TypeSig names _)) = map decl names @@ -152,7 +153,7 @@ imports src@(_, imps, _, _) = everything (<|>) 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.GHCR)) -> 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 53cfccff..8ca9075b 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -178,7 +178,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 @@ -196,7 +196,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 @@ -212,19 +212,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 doc subdocs insts fixities _splice) @@ -247,7 +247,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 @@ -257,7 +257,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 @@ -277,9 +277,9 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) ------------------------------------------------------------------------------- -ppDecl :: LHsDecl DocName +ppDecl :: LHsDecl DocNameI -> DocForDecl DocName - -> [DocInstance DocName] + -> [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX @@ -307,12 +307,12 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of 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" @@ -325,7 +325,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 @@ -344,7 +344,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 @@ -356,7 +356,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) @@ -367,7 +367,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) @@ -385,7 +385,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])) @@ -401,18 +401,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 @@ -461,8 +461,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" @@ -480,9 +480,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 @@ -517,7 +517,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 @@ -535,16 +535,16 @@ 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 @@ -565,9 +565,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ------------------------------------------------------------------------------- -ppDataDecl :: [DocInstance DocName] -> +ppDataDecl :: [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> LaTeX ppDataDecl instances subdocs _loc doc dataDecl unicode @@ -598,7 +598,7 @@ ppDataDecl 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) <+> @@ -610,7 +610,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 @@ -739,7 +739,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 @@ -797,7 +797,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 @@ -814,7 +814,7 @@ 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 :: DocName -> [HsType DocNameI] -> [HsType DocNameI] -> Bool -> LaTeX ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) @@ -841,29 +841,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) @@ -913,32 +913,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 @@ -1001,7 +1001,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 0c9abbf2..4a3562ae 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -580,7 +580,7 @@ miniSynopsis mdl iface unicode qual = exports = numberSectionHeadings (ifaceRnExportItems iface) -processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName +processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocNameI -> [Html] processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = ((divTopDecl <<).(declElem <<)) <$> case decl0 of @@ -604,14 +604,14 @@ ppNameMini notation mdl nm = << ppBinder' notation nm -ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocNameI -> Html ppTyClBinderWithVarsMini mdl decl = let n = tcdName decl ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName ppModuleContents :: Qualification - -> [ExportItem DocName] + -> [ExportItem DocNameI] -> Bool -- ^ Orphans sections -> Html ppModuleContents qual exports orphan @@ -627,7 +627,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 ) @@ -644,9 +644,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 @@ -655,7 +655,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 2aec5272..2d9d7392 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -40,8 +40,8 @@ import Name import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] +ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI + -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (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 @@ -59,14 +59,14 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl 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) @@ -75,7 +75,7 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = pp_typ = ppLType unicode qual 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 @@ -90,7 +90,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 -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode qual = @@ -107,7 +107,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 -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual @@ -121,7 +121,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 @@ -140,7 +140,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) do_args n leader t = [(leader <+> ppType unicode qual 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 @@ -171,15 +171,15 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge -- | Pretty-print type variables. -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars :: [LHsTyVarBndr DocNameI] -> [Html] ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) 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 @@ -189,7 +189,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 }) @@ -220,7 +220,7 @@ ppTyName = ppName Prefix ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan - -> [DocName] -> HsType DocName + -> [DocName] -> HsType DocNameI -> Html ppSimpleSig links splice unicode qual loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode @@ -235,7 +235,7 @@ ppSimpleSig links splice unicode qual loc names typ = -------------------------------------------------------------------------------- -ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html ppFamilyInfo assoc OpenTypeFamily | assoc = keyword "type" | otherwise = keyword "type family" @@ -245,7 +245,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 @@ -275,28 +275,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 <+> 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 @@ -326,7 +326,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocName + -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyDecl links splice unicode qual decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = @@ -340,7 +340,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 @@ -351,12 +351,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) (map unLoc $ hsq_explicit tvs) -- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppDataBinderWithVars :: Bool -> TyClDecl DocNameI -> Html ppDataBinderWithVars summ decl = ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) @@ -364,7 +364,7 @@ ppDataBinderWithVars summ decl = -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual) where @@ -373,7 +373,7 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs = ppBinderFixity _ = ppBinder -- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] +ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI] -> Unicode -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) @@ -405,30 +405,30 @@ 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 -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html +ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html +ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> Html ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ ppContextNoLocsMaybe cxt unicode qual -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html +ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> Maybe Html ppContextNoLocsMaybe [] _ _ = Nothing ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html +ppContext :: HsContext DocNameI -> Unicode -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -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) cxt) @@ -439,8 +439,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- -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" @@ -457,7 +457,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 @@ -489,9 +489,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 @@ -563,7 +563,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 @@ -571,22 +571,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) @@ -596,7 +596,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 @@ -630,7 +630,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> [PseudoFamilyDecl DocName] + -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = map ppFamilyDecl' @@ -639,7 +639,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 @@ -652,7 +652,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 @@ -672,7 +672,7 @@ instanceId origin no orphan ihd = concat $ -- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader @@ -700,9 +700,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual ConDeclGADT{} -> False -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> + SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl splice unicode qual @@ -738,7 +738,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl -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 @@ -746,7 +746,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 -> @@ -787,7 +787,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) @@ -801,7 +801,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 @@ -831,7 +831,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 ty @@ -859,7 +859,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 <+> ppLType unicode qual ltype, mbDoc, @@ -870,7 +870,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 ltype @@ -878,7 +878,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 @@ -941,40 +941,40 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html + -> Located (HsType DocNameI) -> Html ppLType unicode qual y = ppType unicode qual (unLoc y) ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html + -> HsType DocNameI -> Html ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual -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 -ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart :: [LHsTyVarBndr DocNameI] -> Unicode -> Html ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html +ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual @@ -1044,7 +1044,7 @@ ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> Html ppr_fun_ty ctxt_prec ty1 ty2 unicode qual = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual p2 = ppr_mono_lty pREC_TOP ty2 unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 01261477..03134695 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -49,7 +49,7 @@ import Haddock.Interface.Specialize -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) +tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GHCR)) tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. @@ -108,7 +108,7 @@ 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 GHCR synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args @@ -120,7 +120,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , tfe_fixity = Prefix , tfe_rhs = hs_rhs } -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GHCR) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax @@ -136,7 +136,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 GHCR) synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ @@ -247,14 +247,14 @@ synifyTyCon coax tc dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn Name) + -> Maybe (LInjectivityAnn GHCR) 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 GHCR synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = @@ -265,7 +265,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 GHCR) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -322,22 +322,22 @@ synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig :: SynifyTypeState -> Id -> Sig GHCR synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name +synifyTcIdSig :: SynifyTypeState -> Id -> Sig GHCR synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext Name +synifyCtx :: [PredType] -> LHsContext GHCR synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsQTyVars Name +synifyTyVars :: [TyVar] -> LHsQTyVars GHCR synifyTyVars ktvs = HsQTvs { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar :: TyVar -> LHsTyVarBndr GHCR synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) @@ -361,20 +361,20 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +synifySigType :: SynifyTypeState -> Type -> LHsSigType GHCR -- 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 GHCR -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType Name +synifyPatSynSigType :: PatSyn -> LHsSigType GHCR -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType :: SynifyTypeState -> Type -> LHsType GHCR synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) @@ -431,7 +431,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 GHCR 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] @@ -451,10 +451,10 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind Name +synifyKindSig :: Kind -> LHsKind GHCR synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GHCR synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks @@ -473,7 +473,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead 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 GHCR) synifyFamInst fi opaque = do ityp' <- ityp $ fi_flavor fi return InstHead diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index c8e5ea8b..16c589f0 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -46,7 +46,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 @@ -73,10 +73,10 @@ getInstLoc (TyFamInstD (TyFamInstDecl -- 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)) = @@ -98,10 +98,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 @@ -126,7 +126,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 _ = [] @@ -151,7 +151,7 @@ reL = L undefined ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl Name) where +instance NamedThing (TyClDecl GHCR) where getName = tcdName ------------------------------------------------------------------------------- @@ -163,14 +163,14 @@ class Parent a where children :: a -> [Name] -instance Parent (ConDecl Name) where +instance Parent (ConDecl GHCR) 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 GHCR) where children d | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d @@ -185,12 +185,12 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name]) family = getName &&& children -familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl :: ConDecl GHC.GHCR -> [(IdP GHCR, [IdP GHCR])] 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 GHCR -> [(IdP GHCR, [IdP GHCR])] families d | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] @@ -198,12 +198,12 @@ families d -- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap :: TyClDecl GHCR -> [(IdP GHCR, IdP GHCR)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] +parents :: IdP GHCR -> HsDecl GHCR -> [IdP GHCR] 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 1d643ac9..f920d75e 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -167,7 +167,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface ] where - formatName :: SrcSpan -> HsDecl Name -> String + formatName :: SrcSpan -> HsDecl GHCR -> 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 d5d74819..b89a14f4 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 @@ -66,7 +67,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GHCR] 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) ] @@ -76,8 +77,8 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem Name - -> Ghc (ExportItem Name) + -> ExportItem GHCR + -> Ghc (ExportItem GHCR) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e594feae..800c58ef 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 #-} ----------------------------------------------------------------------------- -- | @@ -288,7 +289,7 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] - -> [(LHsDecl Name, [HsDocString])] + -> [(LHsDecl GHCR, [HsDocString])] -> Maps mkMaps dflags gre instances decls = let (a, b, c, d) = unzip4 $ map mappings decls @@ -300,11 +301,11 @@ mkMaps dflags gre instances decls = f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) f' = M.fromListWith metaDocAppend . concat - mappings :: (LHsDecl Name, [HsDocString]) + mappings :: (LHsDecl GHCR, [HsDocString]) -> ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] - , [(Name, [LHsDecl Name])] + , [(Name, [LHsDecl GHCR])] ) mappings (ldecl, docStrs) = let L l decl = ldecl @@ -334,7 +335,7 @@ mkMaps dflags gre instances decls = instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: SrcSpan -> HsDecl Name -> [Name] + names :: SrcSpan -> HsDecl GHCR -> [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 @@ -358,12 +359,12 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates :: InstMap -> HsDecl GHCR -> [(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 + , dfid_defn = defn } <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn InstD (DataFamInstD d) -> dataSubs (dfid_defn d) TyClD d | isClassDecl d -> classSubs d @@ -373,7 +374,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 GHCR -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) @@ -390,7 +391,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 GHCR -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -410,7 +411,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 GHCR -> [(LHsDecl GHCR, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -422,18 +423,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 GHCR -> [(LHsDecl GHCR, [HsDocString])] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap +mkFixMap :: HsGroup GHCR -> 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 GHCR -> [LHsDecl GHCR] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -533,14 +534,14 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] -- renamed source declarations + -> [LHsDecl GHCR] -- renamed source declarations -> Maps -> FixMap -> [SrcSpan] -- splice locations - -> Maybe [IE Name] + -> Maybe [IE GHCR] -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem Name] + -> ErrMsgGhc [ExportItem GHCR] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = @@ -570,7 +571,7 @@ mkExportItems Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem Name ] + declWith :: Name -> ErrMsgGhc [ ExportItem GHCR ] declWith t = do r <- findDecl t case r of @@ -640,7 +641,7 @@ mkExportItems _ -> return [] - mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl :: Name -> LHsDecl GHCR -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GHCR mkExportDecl name decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False @@ -652,7 +653,7 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: Name -> ErrMsgGhc ([LHsDecl GHCR], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == semMod = case M.lookup n declMap of @@ -688,7 +689,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 GHCR)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -710,7 +711,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 GHCR) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -755,13 +756,13 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the renamed declarations in A + -> [LHsDecl GHCR] -- ^ 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 + -> ErrMsgGhc [ExportItem GHCR] -- ^ 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 @@ -813,8 +814,8 @@ fullModuleContents :: DynFlags -> Maps -> FixMap -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl Name] -- ^ All the renamed declarations - -> ErrMsgGhc [ExportItem Name] + -> [LHsDecl GHCR] -- ^ All the renamed declarations + -> ErrMsgGhc [ExportItem GHCR] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where @@ -831,7 +832,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs - mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) + mkExportItem :: LHsDecl GHCR -> ErrMsgGhc (Maybe (ExportItem GHCR)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do return . Just . ExportGroup lev "" $ processDocString dflags gre docStr mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do @@ -871,7 +872,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap -- 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 -> LHsDecl GHCR -> LHsDecl GHCR extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = @@ -912,8 +913,8 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name +extractRecSel :: Name -> Name -> [LHsType GHCR] -> [LConDecl GHCR] + -> LSig GHCR extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -922,7 +923,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 GHCR] -> [(SrcSpan, LConDeclField GHCR)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty @@ -931,14 +932,14 @@ 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 GHCR] -> [ExportItem GHCR] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames :: Maps -> [ExportItem GHCR] -> [DocOption] -> [Name] mkVisibleNames (_, _, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports @@ -982,7 +983,7 @@ mkTokenizedSrc ms src = rawSrc = readFile $ msHsFilePath ms -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GHCR] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b43860fb..2c51cf40 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 GHCR] -> 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 GHCR -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType :: LHsSigType GHCR -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType :: LHsSigWcType GHCR -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLKind :: LHsKind GHCR -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind GHCR) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig :: LFamilyResultSig GHCR -> 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 GHCR -> 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 GHCR) + -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType Name -> RnM (HsType DocName) +renameType :: HsType GHCR -> 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 GHCR -> 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 GHCR -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n ; return (L loc (UserTyVar (L l n'))) } @@ -283,15 +283,15 @@ 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 GHCR] -> 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 GHCR -> RnM (HsWildCardInfo DocNameI) renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name -renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead :: InstHead GHCR -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName kinds <- mapM renameType ihdKinds @@ -311,11 +311,11 @@ renameInstHead InstHead {..} = do , ihdInstType = itype } -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl :: LHsDecl GHCR -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl :: HsDecl GHCR -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d @@ -334,10 +334,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 GHCR -> RnM (a DocNameI)) -> Located (a GHCR) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L loc =<< fn x -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) +renameTyClD :: TyClDecl GHCR -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do @@ -379,7 +379,7 @@ renameTyClD d = case d of renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl :: FamilyDecl GHCR -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars , fdFixity = fixity @@ -397,8 +397,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl Name - -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl :: PseudoFamilyDecl GHCR + -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo <*> renameL pfdLName @@ -406,14 +406,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo :: FamilyInfo GHCR -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn :: HsDataDefn GHCR -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext @@ -424,7 +424,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 GHCR -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_doc = mbldoc }) = do @@ -455,19 +455,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 GHCR -> 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 GHCR -> 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 GHCR -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames @@ -491,7 +491,7 @@ renameSig sig = case sig of _ -> error "expected TypeSig" -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) +renameForD :: ForeignDecl GHCR -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLSigType ltype @@ -502,7 +502,7 @@ renameForD (ForeignExport lname ltype co x) = do return (ForeignExport lname' ltype' co x) -renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameInstD :: InstDecl GHCR -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) @@ -513,7 +513,7 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName) +renameDerivD :: DerivDecl GHCR -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do @@ -522,7 +522,7 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameClsInstD :: ClsInstDecl GHCR -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do @@ -535,13 +535,13 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD :: TyFamInstDecl GHCR -> 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 :: LTyFamInstEqn GHCR -> RnM (LTyFamInstEqn DocNameI) 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 @@ -551,7 +551,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) +renameLTyFamDefltEqn :: LTyFamDefltEqn GHCR -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs @@ -561,7 +561,7 @@ renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) +renameDataFamInstD :: DataFamInstDecl GHCR -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats @@ -572,8 +572,8 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fi , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs Name in_thing - -> RnM (HsImplicitBndrs DocName out_thing) + -> HsImplicitBndrs GHCR in_thing + -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' @@ -581,21 +581,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 GHCR 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 GHCR -> 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 GHCR -> 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 28bbf305..d8bdecec 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -30,9 +30,9 @@ import qualified Data.Set as Set -- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) +specialize :: (Eq (IdP name), Typeable name) => Data a - => name -> HsType name -> a -> a + => IdP name -> HsType name -> a -> a specialize name details = everywhere $ mkT step where @@ -44,9 +44,9 @@ specialize name details = -- -- It is just a convenience function wrapping 'specialize' that supports more -- that one specialization. -specialize' :: (Eq name, Typeable name) +specialize' :: (Eq (IdP name), Typeable name) => Data a - => [(name, HsType name)] -> a -> a + => [(IdP name, HsType name)] -> a -> a specialize' = flip $ foldr (uncurry specialize) @@ -54,7 +54,7 @@ specialize' = flip $ foldr (uncurry specialize) -- -- 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 :: (Eq name, DataId name) +specializeTyVarBndrs :: (Eq (IdP name), DataId name) => Data a => LHsQTyVars name -> [HsType name] -> a -> a @@ -66,7 +66,7 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, DataId name) +specializePseudoFamilyDecl :: (Eq (IdP name), DataId name) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name @@ -76,7 +76,7 @@ specializePseudoFamilyDecl bndrs typs decl = specializeTyVars = specializeTyVarBndrs bndrs typs -specializeSig :: forall name . (Eq name, DataId name, SetName name) +specializeSig :: forall name . (Eq (IdP name), DataId name, SetName (IdP name)) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name @@ -93,7 +93,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, DataId name, SetName name) +specializeInstHead :: (Eq (IdP name), DataId name, SetName (IdP name)) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -113,7 +113,7 @@ 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 = everywhere $ mkT step @@ -122,7 +122,7 @@ sugar = step = 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 @@ -131,7 +131,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 @@ -148,7 +148,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 @@ -216,7 +216,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 NameRep freeVariables = everythingWithState Set.empty Set.union query @@ -239,7 +239,7 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name +rename :: SetName (IdP name) => Set NameRep -> HsType name -> HsType name rename fv typ = runReader (renameType typ) $ RenameEnv { rneFV = fv , rneCtx = Map.empty @@ -258,7 +258,7 @@ data RenameEnv name = RenameEnv } -renameType :: SetName name => HsType name -> Rename name (HsType name) +renameType :: SetName (IdP name) => HsType name -> Rename (IdP name) (HsType name) renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> HsForAllTy <$> pure bndrs' @@ -294,19 +294,19 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType :: SetName (IdP name) => LHsType name -> Rename (IdP name) (LHsType name) renameLType = located renameType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: SetName (IdP name) => [LHsType name] -> Rename (IdP name) [LHsType name] renameLTypes = mapM renameLType -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext :: SetName (IdP name) => HsContext name -> Rename (IdP name) (HsContext name) renameContext = renameLTypes {- -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp :: SetName (IdP name) => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname -} @@ -317,21 +317,21 @@ renameName name = do pure $ fromMaybe name (Map.lookup (getName name) ctx) -rebind :: SetName name - => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) - -> Rename name a +rebind :: SetName (IdP name) + => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename (IdP name) a) + -> Rename (IdP name) a rebind lbndrs action = do (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask local (const env') (action lbndrs') -rebindLTyVarBndrs :: SetName name - => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] +rebindLTyVarBndrs :: SetName (IdP name) + => [LHsTyVarBndr name] -> Rebind (IdP name) [LHsTyVarBndr name] rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) +rebindTyVarBndr :: SetName (IdP name) + => HsTyVarBndr name -> Rebind (IdP name) (HsTyVarBndr name) rebindTyVarBndr (UserTyVar (L l name)) = UserTyVar . L l <$> rebindName name rebindTyVarBndr (KindedTyVar name kinds) = @@ -402,6 +402,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/Types.hs b/haddock-api/src/Haddock/Types.hs index e2bbe6f8..b595c856 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -57,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 GHCR] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -99,7 +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]) + , ifaceDeclMap :: !(Map Name [LHsDecl GHCR]) -- | Documentation of declarations originating from the module (including -- subordinates). @@ -114,8 +114,8 @@ data Interface = Interface , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: ![ExportItem DocName] + , ifaceExportItems :: ![ExportItem GHCR] + , ifaceRnExportItems :: ![ExportItem DocNameI] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -133,8 +133,8 @@ data Interface = Interface , ifaceFamInstances :: ![FamInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance Name] - , ifaceRnOrphanInstances :: ![DocInstance DocName] + , ifaceOrphanInstances :: ![DocInstance GHCR] + , 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. @@ -217,17 +217,17 @@ data ExportItem 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. @@ -237,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. @@ -253,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 @@ -297,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 @@ -351,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 @@ -370,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 } @@ -392,12 +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 data InstHead name = InstHead - { ihdClsName :: name + { ihdClsName :: IdP name , ihdKinds :: [HsType name] , ihdTypes :: [HsType name] , ihdInstType :: InstType name @@ -676,14 +672,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 404cfcf6..e5d589e0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -125,12 +125,12 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +mkEmptySigWcType :: LHsType GHCR -> LHsSigWcType GHCR -- 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 :: IdP GHCR -> LHsQTyVars GHCR -> LSig GHCR -> LSig GHCR -- 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)))) @@ -148,7 +148,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 GHCR -> [LHsType GHCR] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -158,7 +158,7 @@ lHsQTyVarsToTypes tvs -------------------------------------------------------------------------------- -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name +restrictTo :: [IdP GHCR] -> LHsDecl GHCR -> LHsDecl GHCR restrictTo names (L loc decl) = L loc $ case decl of TyClD d | isDataDecl d -> TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) @@ -167,7 +167,7 @@ restrictTo names (L loc decl) = L loc $ case decl of tcdATs = restrictATs names (tcdATs d) }) _ -> decl -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name +restrictDataDefn :: [IdP GHCR] -> HsDataDefn GHCR -> HsDataDefn GHCR restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) | DataType <- new_or_data = defn { dd_cons = restrictCons names cons } @@ -177,7 +177,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 :: [IdP GHCR] -> [LConDecl GHCR] -> [LConDecl GHCR] 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) = @@ -197,7 +197,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 GHCR c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty @@ -208,18 +208,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 GHCR -> 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 :: [IdP GHCR] -> [LSig GHCR] -> [LSig GHCR] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] +restrictATs :: [IdP GHCR] -> [LFamilyDecl GHCR] -> [LFamilyDecl GHCR] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] emptyHsQTvs :: LHsQTyVars Name -- cgit v1.2.3 From a9f774fa3c12f9b8e093e46d58e7872d3d478951 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 24 May 2017 17:39:06 +0200 Subject: Rename extension index tags --- haddock-api/src/Haddock/Backends/Hoogle.hs | 22 +++--- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 24 +++---- haddock-api/src/Haddock/Convert.hs | 40 +++++------ haddock-api/src/Haddock/GhcUtils.hs | 14 ++-- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 62 ++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 78 +++++++++++----------- haddock-api/src/Haddock/Types.hs | 8 +-- haddock-api/src/Haddock/Utils.hs | 20 +++--- 10 files changed, 138 insertions(+), 138 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 86e4ca30..02430deb 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -116,7 +116,7 @@ commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem GHCR -> [String] +ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs @@ -134,7 +134,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig GHCR -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where @@ -146,17 +146,17 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs ppSigWithDoc _ _ _ = [] -ppSig :: DynFlags -> Sig GHCR -> [String] +ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GHCR -> 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 GHCR -> [(Name, DocForDecl Name)] -> [String] +ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where @@ -178,7 +178,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn GHCR -> TyClDecl GHCR + tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe , tcdTyVars = tfe_pats tfe @@ -200,10 +200,10 @@ ppInstance dflags x = cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } -ppSynonym :: DynFlags -> TyClDecl GHCR -> [String] +ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl GHCR -> [(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) @@ -224,7 +224,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: DynFlags -> TyClDecl GHCR -> [(Name, DocForDecl Name)] -> ConDecl GHCR -> [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) @@ -257,8 +257,8 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {} name = out dflags $ map unL $ getConNames con -ppFixity :: DynFlags -> (IdP GHCR, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GHCR)] +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +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 abdcafcc..1b39e5e8 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -56,13 +56,13 @@ variables = everything (<|>) (var `combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GHCR)) -> + (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.GHCR) _) -> + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> pure (sspan, RtkVar name) _ -> empty @@ -72,7 +72,7 @@ types = everything (<|>) ty where ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GHCR)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -86,11 +86,11 @@ binds = everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GHCR)) -> + (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)) :: GHC.LPat GHC.GHCR)) -> + (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)] ++ everything (<|>) rec recs @@ -98,11 +98,11 @@ binds = pure (sspan, RtkBind name) _ -> empty rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GHCR) _)) -> + (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)) :: GHC.LHsTyVarBndr GHC.GHCR)) -> + (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) @@ -122,21 +122,21 @@ 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.GHCR)) + (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 :: GHC.ConDecl GHC.GHCR)) -> + (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GHCR)) + (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.dfid_tycon inst (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> pure . tyref $ GHC.tfe_tycon eqn _ -> empty fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.GHCR) + 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 @@ -153,7 +153,7 @@ imports src@(_, imps, _, _) = everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GHCR)) -> 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/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 03134695..19ed74ef 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -49,7 +49,7 @@ import Haddock.Interface.Specialize -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GHCR)) +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. @@ -108,7 +108,7 @@ tyThingToLHsDecl t = case t of withErrs e x = return (e, x) allOK x = return (mempty, x) -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GHCR +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 @@ -120,7 +120,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , tfe_fixity = Prefix , tfe_rhs = hs_rhs } -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GHCR) +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax @@ -136,7 +136,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 GHCR) +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ @@ -247,14 +247,14 @@ synifyTyCon coax tc dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn GHCR) + -> 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 GHCR +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = @@ -265,7 +265,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 GHCR) +synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -322,22 +322,22 @@ synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -synifyIdSig :: SynifyTypeState -> Id -> Sig GHCR +synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GHCR +synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext GHCR +synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsQTyVars GHCR +synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr GHCR +synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) @@ -361,20 +361,20 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GHCR +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 GHCR +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType GHCR +synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GHCR +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) @@ -431,7 +431,7 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" -synifyPatSynType :: PatSyn -> LHsType GHCR +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] @@ -451,10 +451,10 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind GHCR +synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GHCR +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks @@ -473,7 +473,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GHCR) +synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) synifyFamInst fi opaque = do ityp' <- ityp $ fi_flavor fi return InstHead diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 16c589f0..83e4dbd8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -151,7 +151,7 @@ reL = L undefined ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl GHCR) where +instance NamedThing (TyClDecl GhcRn) where getName = tcdName ------------------------------------------------------------------------------- @@ -163,14 +163,14 @@ class Parent a where children :: a -> [Name] -instance Parent (ConDecl GHCR) 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 GHCR) where +instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d @@ -185,12 +185,12 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name]) family = getName &&& children -familyConDecl :: ConDecl GHC.GHCR -> [(IdP GHCR, [IdP GHCR])] +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 GHCR -> [(IdP GHCR, [IdP GHCR])] +families :: TyClDecl GhcRn -> [(Name, [Name])] families d | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] @@ -198,12 +198,12 @@ families d -- | A mapping from child to parent -parentMap :: TyClDecl GHCR -> [(IdP GHCR, IdP GHCR)] +parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: IdP GHCR -> HsDecl GHCR -> [IdP GHCR] +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 f920d75e..31991e25 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -167,7 +167,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface ] where - formatName :: SrcSpan -> HsDecl GHCR -> 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 b89a14f4..6d0bed2a 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -67,7 +67,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GHCR] +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) ] @@ -77,8 +77,8 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem GHCR - -> Ghc (ExportItem GHCR) + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 800c58ef..2b352d90 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -289,7 +289,7 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] - -> [(LHsDecl GHCR, [HsDocString])] + -> [(LHsDecl GhcRn, [HsDocString])] -> Maps mkMaps dflags gre instances decls = let (a, b, c, d) = unzip4 $ map mappings decls @@ -301,11 +301,11 @@ mkMaps dflags gre instances decls = f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) f' = M.fromListWith metaDocAppend . concat - mappings :: (LHsDecl GHCR, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDocString]) -> ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] - , [(Name, [LHsDecl GHCR])] + , [(Name, [LHsDecl GhcRn])] ) mappings (ldecl, docStrs) = let L l decl = ldecl @@ -335,7 +335,7 @@ mkMaps dflags gre instances decls = instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: SrcSpan -> HsDecl GHCR -> [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 @@ -359,7 +359,7 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: InstMap -> HsDecl GHCR -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _ @@ -374,7 +374,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 GHCR -> [(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) @@ -391,7 +391,7 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. -typeDocs :: HsDecl GHCR -> Map Int HsDocString +typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -411,7 +411,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 GHCR -> [(LHsDecl GHCR, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -423,18 +423,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 GHCR -> [(LHsDecl GHCR, [HsDocString])] +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup GHCR -> 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 GHCR -> [LHsDecl GHCR] +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -534,14 +534,14 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl GHCR] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap -> [SrcSpan] -- splice locations - -> Maybe [IE GHCR] + -> Maybe [IE GhcRn] -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem GHCR] + -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = @@ -571,7 +571,7 @@ mkExportItems Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem GHCR ] + declWith :: Name -> ErrMsgGhc [ ExportItem GhcRn ] declWith t = do r <- findDecl t case r of @@ -641,7 +641,7 @@ mkExportItems _ -> return [] - mkExportDecl :: Name -> LHsDecl GHCR -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GHCR + mkExportDecl :: Name -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn mkExportDecl name decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False @@ -653,7 +653,7 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> ErrMsgGhc ([LHsDecl GHCR], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: Name -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == semMod = case M.lookup n declMap of @@ -689,7 +689,7 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GHCR)) +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -711,7 +711,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 GHCR) + -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -756,13 +756,13 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [LHsDecl GHCR] -- ^ All the renamed declarations in A + -> [LHsDecl GhcRn] -- ^ 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 GHCR] -- ^ Resulting export items + -> ErrMsgGhc [ExportItem GhcRn] -- ^ 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 @@ -814,8 +814,8 @@ fullModuleContents :: DynFlags -> Maps -> FixMap -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl GHCR] -- ^ All the renamed declarations - -> ErrMsgGhc [ExportItem GHCR] + -> [LHsDecl GhcRn] -- ^ All the renamed declarations + -> ErrMsgGhc [ExportItem GhcRn] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where @@ -832,7 +832,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs - mkExportItem :: LHsDecl GHCR -> ErrMsgGhc (Maybe (ExportItem GHCR)) + mkExportItem :: LHsDecl GhcRn -> ErrMsgGhc (Maybe (ExportItem GhcRn)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do return . Just . ExportGroup lev "" $ processDocString dflags gre docStr mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do @@ -872,7 +872,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap -- 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 GHCR -> LHsDecl GHCR +extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = @@ -913,8 +913,8 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType GHCR] -> [LConDecl GHCR] - -> LSig GHCR +extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] + -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -923,7 +923,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 GHCR] -> [(SrcSpan, LConDeclField GHCR)] + 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 @@ -932,14 +932,14 @@ 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 GHCR] -> [ExportItem GHCR] +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem GHCR] -> [DocOption] -> [Name] +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] mkVisibleNames (_, _, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports @@ -983,7 +983,7 @@ mkTokenizedSrc ms src = rawSrc = readFile $ msHsFilePath ms -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl GHCR] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2c51cf40..70846b31 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 GHCR] -> RnM [ExportItem DocNameI] +renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -172,22 +172,22 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc -renameLType :: LHsType GHCR -> RnM (LHsType DocNameI) +renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType GHCR -> RnM (LHsSigType DocNameI) +renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType GHCR -> RnM (LHsSigWcType DocNameI) +renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind GHCR -> RnM (LHsKind DocNameI) +renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind GHCR) -> RnM (Maybe (LHsKind DocNameI)) +renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig GHCR -> RnM (LFamilyResultSig DocNameI) +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 GHCR -> RnM (LInjectivityAnn DocNameI) +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 GHCR) +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType GHCR -> RnM (HsType DocNameI) +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 GHCR -> RnM (LHsQTyVars DocNameI) +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 GHCR -> RnM (LHsTyVarBndr DocNameI) +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,15 +283,15 @@ renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) ; kind' <- renameLKind kind ; return (L loc (KindedTyVar (L lv n') kind')) } -renameLContext :: Located [LHsType GHCR] -> RnM (Located [LHsType DocNameI]) +renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GHCR -> RnM (HsWildCardInfo DocNameI) +renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name -renameInstHead :: InstHead GHCR -> RnM (InstHead DocNameI) +renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName kinds <- mapM renameType ihdKinds @@ -311,11 +311,11 @@ renameInstHead InstHead {..} = do , ihdInstType = itype } -renameLDecl :: LHsDecl GHCR -> RnM (LHsDecl DocNameI) +renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl :: HsDecl GHCR -> RnM (HsDecl DocNameI) +renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d @@ -334,10 +334,10 @@ renameDecl decl = case decl of return (DerivD d') _ -> error "renameDecl" -renameLThing :: (a GHCR -> RnM (a DocNameI)) -> Located (a GHCR) -> RnM (Located (a DocNameI)) +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 GHCR -> RnM (TyClDecl DocNameI) +renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do @@ -379,7 +379,7 @@ renameTyClD d = case d of renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl GHCR -> RnM (FamilyDecl DocNameI) +renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars , fdFixity = fixity @@ -397,7 +397,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl GHCR +renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo @@ -406,14 +406,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo GHCR -> RnM (FamilyInfo DocNameI) +renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn GHCR -> RnM (HsDataDefn DocNameI) +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 @@ -424,7 +424,7 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameCon :: ConDecl GHCR -> RnM (ConDecl DocNameI) +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 @@ -455,19 +455,19 @@ renameCon decl@(ConDeclGADT { con_names = lnames return (decl { con_names = lnames' , con_type = lty', con_doc = mbldoc' }) -renameConDeclFieldField :: LConDeclField GHCR -> RnM (LConDeclField DocNameI) +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 GHCR -> RnM (LFieldOcc DocNameI) +renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc lbl sel)) = do sel' <- rename sel return $ L l (FieldOcc lbl sel') -renameSig :: Sig GHCR -> RnM (Sig DocNameI) +renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames @@ -491,7 +491,7 @@ renameSig sig = case sig of _ -> error "expected TypeSig" -renameForD :: ForeignDecl GHCR -> RnM (ForeignDecl DocNameI) +renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLSigType ltype @@ -502,7 +502,7 @@ renameForD (ForeignExport lname ltype co x) = do return (ForeignExport lname' ltype' co x) -renameInstD :: InstDecl GHCR -> RnM (InstDecl DocNameI) +renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) @@ -513,7 +513,7 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl GHCR -> RnM (DerivDecl DocNameI) +renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do @@ -522,7 +522,7 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl GHCR -> RnM (ClsInstDecl DocNameI) +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 @@ -535,13 +535,13 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl GHCR -> RnM (TyFamInstDecl DocNameI) +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 GHCR -> RnM (LTyFamInstEqn DocNameI) +renameLTyFamInstEqn :: LTyFamInstEqn GhcRn -> RnM (LTyFamInstEqn DocNameI) 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 @@ -551,7 +551,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameLTyFamDefltEqn :: LTyFamDefltEqn GHCR -> RnM (LTyFamDefltEqn DocNameI) +renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs @@ -561,7 +561,7 @@ renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameDataFamInstD :: DataFamInstDecl GHCR -> RnM (DataFamInstDecl DocNameI) +renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats @@ -572,7 +572,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fi , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GHCR in_thing + -> HsImplicitBndrs GhcRn in_thing -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing @@ -581,21 +581,21 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildCardBndrs GHCR in_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 GHCR -> RnM (DocInstance DocNameI) +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 GHCR -> RnM (ExportItem DocNameI) +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/Types.hs b/haddock-api/src/Haddock/Types.hs index b595c856..cb4a4bcc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -57,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 GHCR] +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 @@ -99,7 +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 GHCR]) + , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) -- | Documentation of declarations originating from the module (including -- subordinates). @@ -114,7 +114,7 @@ data Interface = Interface , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem GHCR] + , ifaceExportItems :: ![ExportItem GhcRn] , ifaceRnExportItems :: ![ExportItem DocNameI] -- | All names exported by the module. @@ -133,7 +133,7 @@ data Interface = Interface , ifaceFamInstances :: ![FamInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance GHCR] + , ifaceOrphanInstances :: ![DocInstance GhcRn] , ifaceRnOrphanInstances :: ![DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index e5d589e0..f5c5b743 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -125,12 +125,12 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GHCR -> LHsSigWcType GHCR +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 :: IdP GHCR -> LHsQTyVars GHCR -> LSig GHCR -> LSig GHCR +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)))) @@ -148,7 +148,7 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GHCR -> [LHsType GHCR] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -158,7 +158,7 @@ lHsQTyVarsToTypes tvs -------------------------------------------------------------------------------- -restrictTo :: [IdP GHCR] -> LHsDecl GHCR -> LHsDecl GHCR +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) }) @@ -167,7 +167,7 @@ restrictTo names (L loc decl) = L loc $ case decl of tcdATs = restrictATs names (tcdATs d) }) _ -> decl -restrictDataDefn :: [IdP GHCR] -> HsDataDefn GHCR -> HsDataDefn GHCR +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 } @@ -177,7 +177,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictCons :: [IdP GHCR] -> [LConDecl GHCR] -> [LConDecl GHCR] +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) = @@ -197,7 +197,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 GHCR + c' :: ConDecl GhcRn c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty @@ -208,18 +208,18 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] , con_doc = con_doc c } - field_avail :: LConDeclField GHCR -> 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 :: [IdP GHCR] -> [LSig GHCR] -> [LSig GHCR] +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -restrictATs :: [IdP GHCR] -> [LFamilyDecl GHCR] -> [LFamilyDecl GHCR] +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] emptyHsQTvs :: LHsQTyVars Name -- cgit v1.2.3 From 815d2deb9c0222c916becccf8464b740c26255fd Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 22 Aug 2017 23:02:51 -0400 Subject: Update for #14131 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 9 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 5 +- haddock-api/src/Haddock/Convert.hs | 18 +++--- haddock-api/src/Haddock/GhcUtils.hs | 5 +- haddock-api/src/Haddock/Interface/Create.hs | 28 +++++---- haddock-api/src/Haddock/Interface/Rename.hs | 69 +++++++++++++--------- 7 files changed, 83 insertions(+), 61 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 56f8176c..8e4e801e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -184,11 +184,11 @@ ppClass dflags decl subdocs = 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 } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 759a31d4..57ff72ff 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -159,10 +159,11 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn)) - -> 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.GhcRn) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 59ad41e4..3b53b1eb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -318,8 +318,9 @@ 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 }} + 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, [] ) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 36efb3e4..67aa88e1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -113,20 +113,20 @@ 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 } + in HsIB { hsib_vars = map tyVarName tkvs + , hsib_closed = True + , hsib_body = FamEqn { feqn_tycon = name + , feqn_pats = typats + , feqn_fixity = Prefix + , feqn_rhs = hs_rhs } } 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 diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 561c126f..a1009c1f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -59,12 +59,13 @@ 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.. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 292680a7..62bdbcbe 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -406,11 +406,13 @@ subordinates :: InstMap -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = defn } <- unLoc <$> cid_datafam_insts d + 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) _ -> [] @@ -1004,17 +1006,19 @@ 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) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2e9a311a..70962d9c 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -415,7 +415,7 @@ 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 GhcRn -> RnM (HsDataDefn DocNameI) @@ -542,39 +542,54 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode 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 GhcRn -> RnM (LTyFamInstEqn DocNameI) -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' }) } + +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 (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) +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' })) } + ; 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_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 }) } +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 GhcRn in_thing -- cgit v1.2.3 From 0a64b5cdc051c47b24151b8839ae9067f06d8d0d Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Thu, 21 Sep 2017 23:27:52 +0200 Subject: Make compatible with Prelude.<> export in GHC 8.4/base-4.11 --- haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 023676b3..3f279205 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -38,7 +38,7 @@ library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base >= 4.10.0 + build-depends: base ^>= 4.11.0 , Cabal ^>= 2.0.0 , ghc ^>= 8.3 , ghc-paths ^>= 0.1.0.9 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8e4e801e..f1d8ddb2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -178,7 +178,7 @@ ppClass dflags decl subdocs = whereWrapper elems = vcat' [ text "where" <+> lbrace - , nest 4 . vcat . map (<> semi) $ elems + , nest 4 . vcat . map (Outputable.<> semi) $ elems , rbrace ] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d4a3012e..1cc23e6e 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) -- cgit v1.2.3