aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2018-04-24 16:51:06 -0400
committerAlexander Biehl <alexbiehl@gmail.com>2018-04-24 13:51:06 -0700
commit979c7338cfcdc59f0b0dda562a53558c416cc362 (patch)
tree073baae7f9cfa6cc3c2ed6ca0fd017092cd80c36
parentb347a8c47edafa6bb3df7d35f0189619294831c4 (diff)
Improve the Hoogle backend's treatment of type families (#808)
Fixes parts 1 and 2 of #806.
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs26
-rw-r--r--hoogle-test/ref/Bug806/test.txt24
-rw-r--r--hoogle-test/src/Bug806/Bug806.hs23
3 files changed, 67 insertions, 6 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e002b602..e7ce9d30 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -128,6 +128,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
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 (SigD sig) = ppSig dflags sig ++ ppFixities
@@ -140,11 +141,7 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags (TypeSig names sig) subdocs
= concatMap mkDocSig names
where
- mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
- ++ [pp_sig dflags [n] (hsSigWcType sig)]
-
- getDoc :: Located Name -> [Documentation Name]
- getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
+ mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
ppSigWithDoc _ _ _ = []
@@ -172,10 +169,14 @@ ppClass dflags decl subdocs =
ppTyFams
| null $ tcdATs decl = ""
| otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
- [ map ppr (tcdATs decl)
+ [ map pprTyFam (tcdATs decl)
, map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
]
+ pprTyFam :: LFamilyDecl GhcRn -> SDoc
+ pprTyFam (L _ at) = vcat' $ map text $
+ mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)
+
whereWrapper elems = vcat'
[ text "where" <+> lbrace
, nest 4 . vcat . map (Outputable.<> semi) $ elems
@@ -191,6 +192,15 @@ ppClass dflags decl subdocs =
, tcdFVs = emptyNameSet
}
+ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
+ppFam dflags decl@(FamilyDecl { fdInfo = info })
+ = [out dflags decl']
+ where
+ decl' = case info of
+ -- We don't need to print out a closed type family's equations
+ -- for Hoogle, so pretend it doesn't have any.
+ ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
+ _ -> decl
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x =
@@ -285,6 +295,10 @@ docWith dflags header d
lines header ++ ["" | header /= "" && isJust d] ++
maybe [] (showTags . markup (markupTag dflags)) d
+mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
+ where
+ getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
deriving Show
diff --git a/hoogle-test/ref/Bug806/test.txt b/hoogle-test/ref/Bug806/test.txt
new file mode 100644
index 00000000..d9a908b3
--- /dev/null
+++ b/hoogle-test/ref/Bug806/test.txt
@@ -0,0 +1,24 @@
+-- Hoogle documentation, generated by Haddock
+-- See Hoogle, http://www.haskell.org/hoogle/
+
+@package test
+@version 0.0.0
+
+module Bug806
+
+-- | <a>F1</a> docs
+type family F1 a b :: * -> *
+
+-- | <a>F2</a> docs
+type family F2 a b :: * -> *
+
+-- | <a>D</a> docs
+data family D a :: * -> *
+v :: Int
+
+-- | <a>C</a> docs
+class C a where {
+
+ -- | <a>AT</a> docs
+ type family AT a;
+}
diff --git a/hoogle-test/src/Bug806/Bug806.hs b/hoogle-test/src/Bug806/Bug806.hs
new file mode 100644
index 00000000..6efcb5cf
--- /dev/null
+++ b/hoogle-test/src/Bug806/Bug806.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Bug806 where
+
+import Data.Proxy
+
+-- | 'F1' docs
+type family F1 a b :: * -> *
+-- | 'F2' docs
+type family F2 a b :: * -> * where
+ F2 Int b = Maybe
+ F2 a b = []
+-- | 'D' docs
+data family D a :: * -> *
+
+v :: Int
+v = 42
+
+-- | 'C' docs
+class C a where
+ -- | 'AT' docs
+ type AT a