From 3606ad5fdb8b9c2c3f9a62de1d26702ad41f9a10 Mon Sep 17 00:00:00 2001
From: Niklas Haas <git@nand.wakku.to>
Date: Wed, 12 Mar 2014 10:31:31 +0100
Subject: Hide RHS of TFs with non-exported right hand sides

Not sure what to do about data families yet, since technically it would
not make a lot of sense to display constructors that cannot be used by
the user.
---
 src/Haddock/Backends/LaTeX.hs            | 3 ++-
 src/Haddock/Backends/Xhtml/Decl.hs       | 2 +-
 src/Haddock/Convert.hs                   | 7 ++++---
 src/Haddock/Interface/AttachInstances.hs | 5 ++---
 src/Haddock/Interface/Rename.hs          | 2 +-
 src/Haddock/Types.hs                     | 6 +++---
 6 files changed, 13 insertions(+), 12 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 6535b24e..44b3fc35 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -563,7 +563,8 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
 ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
 ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
-  <+> ppAppNameTypes n ks ts unicode <+> equals <+> ppType unicode rhs
+  <+> ppAppNameTypes n ks ts unicode
+  <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
 ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
   error "data instances not supported by --latex yet"
 
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index c0efa5d0..c1b9032e 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -488,7 +488,7 @@ ppInstances instances baseName unicode qual
         <+> ppAppNameTypes n ks ts unicode qual
     instHead (n, ks, ts, TypeInst rhs) = keyword "type"
         <+> ppAppNameTypes n ks ts unicode qual
-        <+> equals <+> ppType unicode qual rhs
+        <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
     instHead (n, ks, ts, DataInst dd) = keyword "data"
         <+> ppAppNameTypes n ks ts unicode qual
         <+> ppShortDataDecl False True dd unicode qual
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 3670473d..1245b2b9 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -380,13 +380,14 @@ synifyInstHead (_, preds, cls, types) =
   where (ks,ts) = break (not . isKind) types
 
 -- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> InstHead Name
-synifyFamInst fi =
+synifyFamInst :: FamInst -> Bool -> InstHead Name
+synifyFamInst fi opaque =
   ( fi_fam fi
   , map (unLoc . synifyType WithinType) ks
   , map (unLoc . synifyType WithinType) ts
   , case fi_flavor fi of
-      SynFamilyInst -> TypeInst . unLoc . synifyType WithinType $ fi_rhs fi
+      SynFamilyInst | opaque -> TypeInst Nothing
+      SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
       DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
   )
   where (ks,ts) = break (not . isKind) $ fi_tys fi
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 60ae4661..a0bac8fc 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -70,13 +70,12 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
               expItemInstances =
                 case mb_info of
                   Just (_, _, cls_instances, fam_instances) ->
-                    let fam_insts = [ (synifyFamInst i, n)
+                    let fam_insts = [ (synifyFamInst i opaque, n)
                                     | i <- sortBy (comparing instFam) fam_instances
                                     , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
                                     , not $ isNameHidden expInfo (fi_fam i)
                                     , not $ any (isTypeHidden expInfo) (fi_tys i)
-                                    -- Should we check for hidden RHS as well?
-                                    -- Ideally, in that case the RHS should simply not show up
+                                    , let opaque = isTypeHidden expInfo (fi_rhs i)
                                     ]
                         cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
                                     | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index a5cde195..4160f4f7 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -264,7 +264,7 @@ renameInstHead (className, k, types, rest) = do
   types' <- mapM renameType types
   rest' <- case rest of
     ClassInst cs -> ClassInst <$> mapM renameType cs
-    TypeInst  ts -> TypeInst  <$> renameType ts
+    TypeInst  ts -> TypeInst  <$> traverse renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
   return (className', k', types', rest')
 
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 9538f3bf..5930c930 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -291,9 +291,9 @@ instance NamedThing DocName where
 
 -- | The three types of instances
 data InstType name
-  = ClassInst [HsType name]  -- ^ Context
-  | TypeInst  (HsType name)  -- ^ Body (right-hand side)
-  | DataInst (TyClDecl name) -- ^ Data constructors
+  = ClassInst [HsType name]         -- ^ Context
+  | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)
+  | DataInst (TyClDecl name)        -- ^ Data constructors
 
 instance OutputableBndr a => Outputable (InstType a) where
   ppr (ClassInst a) = text "ClassInst" <+> ppr a
-- 
cgit v1.2.3