From b347a8c47edafa6bb3df7d35f0189619294831c4 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 24 Apr 2018 11:20:09 -0400 Subject: Add regression test for #413 Fixes #413. --- hoogle-test/ref/type-sigs/test.txt | 16 ++++++++++++++++ hoogle-test/src/type-sigs/ReaderT.hs | 3 +++ hoogle-test/src/type-sigs/ReaderTReexport.hs | 3 +++ 3 files changed, 22 insertions(+) create mode 100644 hoogle-test/ref/type-sigs/test.txt create mode 100644 hoogle-test/src/type-sigs/ReaderT.hs create mode 100644 hoogle-test/src/type-sigs/ReaderTReexport.hs (limited to 'hoogle-test') diff --git a/hoogle-test/ref/type-sigs/test.txt b/hoogle-test/ref/type-sigs/test.txt new file mode 100644 index 00000000..ec5f5043 --- /dev/null +++ b/hoogle-test/ref/type-sigs/test.txt @@ -0,0 +1,16 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module ReaderT +newtype ReaderT r m a +ReaderT :: r -> m a -> ReaderT r m a +[runReaderT] :: ReaderT r m a -> r -> m a + +module ReaderTReexport +newtype ReaderT r m a +ReaderT :: r -> m a -> ReaderT r m a +[runReaderT] :: ReaderT r m a -> r -> m a +runReaderT :: ReaderT r m a -> r -> m a diff --git a/hoogle-test/src/type-sigs/ReaderT.hs b/hoogle-test/src/type-sigs/ReaderT.hs new file mode 100644 index 00000000..009c7ed2 --- /dev/null +++ b/hoogle-test/src/type-sigs/ReaderT.hs @@ -0,0 +1,3 @@ +module ReaderT where + +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } diff --git a/hoogle-test/src/type-sigs/ReaderTReexport.hs b/hoogle-test/src/type-sigs/ReaderTReexport.hs new file mode 100644 index 00000000..21fa44ee --- /dev/null +++ b/hoogle-test/src/type-sigs/ReaderTReexport.hs @@ -0,0 +1,3 @@ +module ReaderTReexport (ReaderT(..), runReaderT) where + +import ReaderT -- cgit v1.2.3 From 979c7338cfcdc59f0b0dda562a53558c416cc362 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 24 Apr 2018 16:51:06 -0400 Subject: Improve the Hoogle backend's treatment of type families (#808) Fixes parts 1 and 2 of #806. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 26 ++++++++++++++++++++------ hoogle-test/ref/Bug806/test.txt | 24 ++++++++++++++++++++++++ hoogle-test/src/Bug806/Bug806.hs | 23 +++++++++++++++++++++++ 3 files changed, 67 insertions(+), 6 deletions(-) create mode 100644 hoogle-test/ref/Bug806/test.txt create mode 100644 hoogle-test/src/Bug806/Bug806.hs (limited to 'hoogle-test') 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 + +-- | F1 docs +type family F1 a b :: * -> * + +-- | F2 docs +type family F2 a b :: * -> * + +-- | D docs +data family D a :: * -> * +v :: Int + +-- | C docs +class C a where { + + -- | AT 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 -- cgit v1.2.3 From e5098935e723f668fb2d283ef0393e72df32147a Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 10 May 2018 11:19:47 -0400 Subject: Remove Hoogle backend hack that butchers infix datatype names --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +-- hoogle-test/ref/Bug825/test.txt | 9 +++++++++ hoogle-test/src/Bug825/Bug825.hs | 6 ++++++ 3 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/Bug825/test.txt create mode 100644 hoogle-test/src/Bug825/Bug825.hs (limited to 'hoogle-test') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8d0318c2..6d1bdad0 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -225,11 +225,10 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs -- GHC gives out "data Bar =", we want to delete the equals -- also writes data : a b, when we want data (:) a b - showData d = unwords $ map f $ if last xs == "=" then init xs else xs + showData d = unwords $ if last xs == "=" then init xs else xs where xs = words $ out dflags d nam = out dflags $ tyClDeclLName d - f w = if w == nam then operator nam else w ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... diff --git a/hoogle-test/ref/Bug825/test.txt b/hoogle-test/ref/Bug825/test.txt new file mode 100644 index 00000000..a88202dc --- /dev/null +++ b/hoogle-test/ref/Bug825/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug825 +data a :~: b +data (:~~:) a b diff --git a/hoogle-test/src/Bug825/Bug825.hs b/hoogle-test/src/Bug825/Bug825.hs new file mode 100644 index 00000000..bfe07139 --- /dev/null +++ b/hoogle-test/src/Bug825/Bug825.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +module Bug825 where + +data a :~: b +data (:~~:) a b -- cgit v1.2.3