aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Hoogle.hs
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2020-09-23 20:37:34 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2020-10-30 19:35:59 -0400
commitad9cbad7312a64e6757c32bd9488c55ba4f2fec9 (patch)
tree1c0035b3bf571673c539aad1b992a8a392d7bf4b /haddock-api/src/Haddock/Backends/Hoogle.hs
parent3cce1bdee8c61bb6daa089059e12435178f50770 (diff)
Adapt to HsOuterTyVarBndrs
These changes accompany ghc/ghc!4107, which aims to be a fix for #16762.
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hoogle.hs')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs61
1 files changed, 33 insertions, 28 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 8939664d..44841bc5 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -71,27 +71,31 @@ ppModule dflags iface =
---------------------------------------------------------------------
-- Utility functions
-dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
-dropHsDocTy = f
+dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p)
+dropHsDocTy = drop_sig_ty
where
- g (L src x) = L src (f x)
- f (HsForAllTy x a e) = HsForAllTy x a (g e)
- f (HsQualTy x a e) = HsQualTy x a (g e)
- f (HsBangTy x a b) = HsBangTy x a (g b)
- f (HsAppTy x a b) = HsAppTy x (g a) (g b)
- f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
- f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
- f (HsListTy x a) = HsListTy x (g a)
- f (HsTupleTy x a b) = HsTupleTy x a (map g b)
- f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
- f (HsParTy x a) = HsParTy x (g a)
- f (HsKindSig x a b) = HsKindSig x (g a) b
- f (HsDocTy _ a _) = f $ unL a
- f x = x
-
-outHsType :: (OutputableBndrId p)
- => DynFlags -> HsType (GhcPass p) -> String
-outHsType dflags = out dflags . reparenType . dropHsDocTy
+ drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b)
+ drop_sig_ty x@XHsSigType{} = x
+
+ drop_lty (L src x) = L src (drop_ty x)
+
+ drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
+ drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
+ drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
+ drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
+ drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
+ drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
+ drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
+ drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
+ drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+ drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
+ drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
+ drop_ty (HsDocTy _ a _) = drop_ty $ unL a
+ drop_ty x = x
+
+outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p)
+ => DynFlags -> HsSigType (GhcPass p) -> String
+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
dropComment :: String -> String
@@ -135,8 +139,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
f (TyClD _ (FamDecl _ d)) = ppFam dflags d
- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
f (SigD _ sig) = ppSig dflags sig
f _ = []
@@ -145,8 +149,8 @@ ppExport _ _ = []
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags sig subdocs = case sig of
- TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names
- PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names
+ TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names
+ PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
_ -> []
where
mkDocSig leader typ n = mkSubdoc dflags n subdocs
@@ -155,9 +159,9 @@ ppSigWithDoc dflags sig subdocs = case sig of
ppSig :: DynFlags -> Sig GhcRn -> [String]
ppSig dflags x = ppSigWithDoc dflags x []
-pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String
+pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String
pp_sig dflags names (L _ typ) =
- operator prettyNames ++ " :: " ++ outHsType dflags typ
+ operator prettyNames ++ " :: " ++ outHsSigType dflags typ
where
prettyNames = intercalate ", " $ map (out dflags) names
@@ -250,7 +254,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+ typeSig nm flds = operator nm ++ " :: " ++
+ outHsSigType dflags (unL $ mkEmptySigType $ funs flds)
-- We print the constructors as comma-separated list. See GHC
-- docs for con_names on why it is a list to begin with.
@@ -269,7 +274,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
where
f = [typeSig name (getGADTConTypeG con)]
- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
+ typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
ppFixity :: DynFlags -> (Name, Fixity) -> [String]