Add support for type/data families

This adds support for type/data families with their respective
instances, as well as closed type families and associated type/data
families.

Signed-off-by: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>

10 files changed, 181 insertions, 138 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 94adc558..2185340b 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -284,7 +284,7 @@ ppDecl :: LHsDecl DocName
 ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
   TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode
   TyClD d@(DataDecl {})
-                                -> ppDataDecl instances subdocs loc doc d unicode
+                                -> ppDataDecl instances subdocs loc (Just doc) d unicode
   TyClD d@(SynDecl {})          -> ppTySyn loc (doc, fnArgsDoc) d unicode
 -- Family instances happen via FamInst now
 --  TyClD d@(TySynonym {})
@@ -560,9 +560,11 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 
 
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode ([],   n, ts) = ppAppNameTypes n ts unicode
-ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
-
+ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode
+ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type"
+  <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs
+ppInstHead _unicode (_n, _ts, DataInst _dd) =
+  error "data instances not supported by --latex yet"
 
 lookupAnySubdoc :: (Eq name1) =>
                    name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
@@ -577,8 +579,8 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
 
 
 ppDataDecl :: [DocInstance DocName] ->
-              [(DocName, DocForDecl DocName)] ->
-              SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
+              [(DocName, DocForDecl DocName)] -> SrcSpan ->
+              Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
               LaTeX
 ppDataDecl instances subdocs _loc doc dataDecl unicode
 
@@ -590,7 +592,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
     cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
-    body = catMaybes [constrBit, documentationToLaTeX doc]
+    body = catMaybes [constrBit, doc >>= documentationToLaTeX]
 
     (whereBit, leaders)
       | null cons = (empty,[])
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 3168c7b0..53b106a2 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -648,6 +648,7 @@ numberSectionHeadings = go 1
 
 processExport :: Bool -> LinksInfo -> Bool -> Qualification
               -> ExportItem DocName -> Maybe Html
+processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _) = Nothing -- Hide empty instances
 processExport summary _ _ qual (ExportGroup lev id0 doc)
   = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
 processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index acde5a0f..9180c3c3 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
           DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
           Bool -> Qualification -> Html
 ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
-  TyClD (FamDecl d)         -> ppTyFam summ False links loc mbDoc d unicode qual
+  TyClD (FamDecl d)         -> ppTyFam summ False links instances loc mbDoc d unicode qual
   TyClD d@(DataDecl {})     -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
   TyClD d@(SynDecl {})      -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
   TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
@@ -212,9 +212,9 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
     Nothing   -> noHtml
   )
 
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Documentation DocName ->
               FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc doc decl unicode qual
+ppTyFam summary associated links instances loc doc decl unicode qual
 
   | summary   = ppTyFamHeader True associated decl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -225,16 +225,19 @@ ppTyFam summary associated links loc doc decl unicode qual
     header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
 
     instancesBit
-      | FamilyDecl { fdInfo = ClosedTypeFamily _eqns } <- decl
+      | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
       , not summary
-      = noHtml -- TODO: print eqns
+      = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
       = ppInstances instances docname unicode qual
 
-    -- TODO: get the instances
-    instances = []
-
+    -- Individual equation of a closed type family
+    ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+                            , tfie_pats = HsWB { hswb_cts = ts }}
+      = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+          <+> equals <+> ppType unicode qual (unLoc rhs)
+        , Nothing, [] )
 
 --------------------------------------------------------------------------------
 -- * Associated Types
@@ -244,7 +247,7 @@ ppTyFam summary associated links loc doc decl unicode qual
 ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
             -> Qualification -> Html
 ppAssocType summ links doc (L loc decl) unicode qual =
-   ppTyFam summ True links loc (fst doc) decl unicode qual
+   ppTyFam summ True links [] loc (fst doc) decl unicode qual
 
 
 --------------------------------------------------------------------------------
@@ -423,10 +426,14 @@ ppInstances instances baseName unicode qual
     instName = getOccString $ getName baseName
     instDecl :: DocInstance DocName -> SubDecl
     instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
-    instHead ([],   n, ts) = ppAppNameTypes n ts unicode qual
-    instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual
+    instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
         <+> ppAppNameTypes n ts unicode qual
-
+    instHead (n, ts, TypeInst rhs) = keyword "type"
+        <+> ppAppNameTypes n ts unicode qual
+        <+> equals <+> ppType unicode qual rhs
+    instHead (n, ts, DataInst dd) = keyword "data"
+        <+> ppAppNameTypes n ts unicode qual
+        <+> ppShortDataDecl False True dd unicode qual
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
@@ -438,9 +445,8 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
 -- TODO: print contexts
-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
-                -> Qualification -> Html
-ppShortDataDecl summary _links _loc dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl unicode qual
 
   | [] <- cons = dataHeader
 
@@ -455,7 +461,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
       +++ shortSubDecls (map doGADTConstr cons)
 
   where
-    dataHeader = ppDataHeader summary dataDecl unicode qual
+    dataHeader
+      | dataInst  = noHtml
+      | otherwise = ppDataHeader summary dataDecl unicode qual
     doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
     doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
 
@@ -469,7 +477,7 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
               Qualification -> Html
 ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
 
-  | summary   = ppShortDataDecl summary links loc dataDecl unicode qual
+  | summary   = ppShortDataDecl summary False dataDecl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
 
   where
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 4584fd82..dbc043be 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
   subArguments,
   subAssociatedTypes,
   subConstructors,
+  subEquations,
   subFields,
   subInstances,
   subMethods,
@@ -165,6 +166,10 @@ subFields :: Qualification -> [SubDecl] -> Html
 subFields qual = divSubDecls "fields" "Fields" . subDlist qual
 
 
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
 subInstances :: Qualification -> String -> [SubDecl] -> Html
 subInstances qual nm = maybe noHtml wrap . instTable
   where
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 66497783..d9bb0fcf 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -30,6 +30,7 @@ import CoAxiom
 import ConLike
 import DataCon
 import PatSyn
+import FamInstEnv
 import BasicTypes ( TupleSort(..) )
 import TysPrim ( alphaTyVars )
 import TysWiredIn ( listTyConName, eqTyCon )
@@ -38,6 +39,7 @@ import Bag ( emptyBag )
 import Unique ( getUnique )
 import SrcLoc ( Located, noLoc, unLoc )
 import Data.List( partition )
+import Haddock.Types
 
 
 -- the main function here! yay!
@@ -62,7 +64,7 @@ tyThingToLHsDecl t = noLoc $ case t of
            extractFamilyDecl _           =
              error "tyThingToLHsDecl: impossible associated tycon"
 
-           atTyClDecls = [synifyTyCon at_tc | (at_tc, _) <- classATItems cl]
+           atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
            atFamDecls  = map extractFamilyDecl atTyClDecls in
        TyClD $ ClassDecl
          { tcdCtxt = synifyCtx (classSCTheta cl)
@@ -80,7 +82,7 @@ tyThingToLHsDecl t = noLoc $ case t of
          , tcdDocs = [] --we don't have any docs at this point
          , tcdFVs = placeHolderNames }
     | otherwise
-    -> TyClD (synifyTyCon tc)
+    -> TyClD (synifyTyCon Nothing tc)
 
   -- type-constructors (e.g. Maybe) are complicated, put the definition
   -- later in the file (also it's used for class associated-types too.)
@@ -119,13 +121,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
 
   | Just ax' <- isClosedSynFamilyTyCon_maybe tc
   , getUnique ax' == getUnique ax   -- without the getUniques, type error
-  = TyClD (synifyTyCon tc)
+  = TyClD (synifyTyCon (Just ax) tc)
 
   | otherwise
   = error "synifyAxiom: closed/open family confusion"
 
-synifyTyCon :: TyCon -> TyClDecl Name
-synifyTyCon tc
+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
+synifyTyCon coax tc
   | isFunTyCon tc || isPrimTyCon tc 
   = DataDecl { tcdLName = synifyName tc
              , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
@@ -181,7 +183,10 @@ synifyTyCon tc
   let
   alg_nd = if isNewTyCon tc then NewType else DataType
   alg_ctx = synifyCtx (tyConStupidTheta tc)
-  name = synifyName tc
+  name = case coax of
+    Just a -> synifyName a -- Data families are named according to their
+                           -- CoAxioms, not their TyCons
+    _ -> synifyName tc
   tyvars = synifyTyVars (tyConTyVars tc)
   kindSig = Just (tyConKind tc)
   -- The data constructors.
@@ -365,10 +370,19 @@ synifyTyLit (StrTyLit s) = HsStrTy s
 synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
-                  ([HsType Name], Name, [HsType Name])
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
 synifyInstHead (_, preds, cls, ts) =
-  ( map (unLoc . synifyType WithinType) preds
-  , getName cls
+  ( getName cls
   , map (unLoc . synifyType WithinType) ts
+  , ClassInst $ map (unLoc . synifyType WithinType) preds
+  )
+
+-- Convert a family instance, this could be a type family or data family
+synifyFamInst :: FamInst -> InstHead Name
+synifyFamInst fi =
+  ( fi_fam fi
+  , map (unLoc . synifyType WithinType) $ fi_tys fi
+  , case fi_flavor fi of
+      SynFamilyInst -> TypeInst . unLoc . synifyType WithinType $ fi_rhs fi
+      DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
   )
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index a8a4f1c9..bf6436d1 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -91,6 +91,17 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
 getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
 getMainDeclBinder _ = []
 
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (DataFamInstD (DataFamInstDecl { dfid_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 _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
 
 -- Useful when there is a signature with multiple names, e.g.
 --   foo, bar :: Types..
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 03d463cb..a56759a5 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -23,6 +23,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import Class
+import FamInstEnv
 import FastString
 import GHC
 import GhcMonad (withSession)
@@ -64,16 +65,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
             export {
               expItemInstances =
                 case mb_info of
-                  Just (_, _, cls_instances, _fam_instances) ->
-{-
-                    let insts = map (first synifyInstHead) $ sortImage (first instHead)
-                                [ (instanceSig i, getName i) | i <- instances ]
--}
-                    let insts = map (first synifyInstHead) $ sortImage (first instHead) $
-                                filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
-                                [ (instanceHead' i, getName i) | i <- cls_instances ]
-                    in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
-                       | (inst, name) <- insts ]
+                  Just (_, _, cls_instances, fam_instances) ->
+                    let fam_insts = [ (synifyFamInst i, n)
+                                    | i <- sortImage instFam fam_instances
+                                    , let n = lookupInstDoc (getName i) iface ifaceMap instIfaceMap
+                                    ]
+                        cls_insts = [ (synifyInstHead i, lookupInstDoc n iface ifaceMap instIfaceMap)
+                                    | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
+                                    , (i@(_,_,cls,tys), n) <- sortImage (first instHead) is
+                                    , not $ isInstanceHidden expInfo cls tys
+                                    ]
+                    in cls_insts ++ fam_insts
                   Nothing -> []
             }
       return export'
@@ -139,22 +141,27 @@ data SimpleType = SimpleType Name [SimpleType]
 instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
 instHead (_, _, cls, args)
   = (map argCount args, className cls, map simplify args)
-  where
-    argCount (AppTy t _) = argCount t + 1
-    argCount (TyConApp _ ts) = length ts
-    argCount (FunTy _ _ ) = 2
-    argCount (ForAllTy _ t) = argCount t
-    argCount _ = 0
-
-    simplify (ForAllTy _ t) = simplify t
-    simplify (FunTy t1 t2) = 
-      SimpleType funTyConName [simplify t1, simplify t2]
-    simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
-      where (SimpleType s ts) = simplify t1
-    simplify (TyVarTy v) = SimpleType (tyVarName v) []
-    simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
-    simplify (LitTy l) = SimpleTyLit l
 
+argCount :: Type -> Int
+argCount (AppTy t _) = argCount t + 1
+argCount (TyConApp _ ts) = length ts
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount _ = 0
+
+simplify :: Type -> SimpleType
+simplify (ForAllTy _ t) = simplify t
+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+  where (SimpleType s ts) = simplify t1
+simplify (TyVarTy v) = SimpleType (tyVarName v) []
+simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (LitTy l) = SimpleTyLit l
+
+-- Used for sorting
+instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
+instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
+  = (map argCount ts, n, map simplify ts, argCount t, simplify t)
 
 -- sortImage f = sortBy (\x y -> compare (f x) (f y))
 sortImage :: Ord b => (a -> b) -> [a] -> [a]
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 6e85ad16..cf5a3451 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -58,9 +58,10 @@ createInterface tm flags modMap instIfaceMap = do
       mdl            = ms_mod ms
       dflags         = ms_hspp_opts ms
       !instances     = modInfoInstances mi
+      !fam_instances = md_fam_insts md
       !exportedNames = modInfoExports mi
 
-      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
+      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
 
   -- The renamed source should always be available to us, but it's best
   -- to be on the safe side.
@@ -80,9 +81,10 @@ createInterface tm flags modMap instIfaceMap = do
 
   let declsWithDocs = topDecls group_
       (decls, _) = unzip declsWithDocs
-      localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
+      localInsts = filter (nameIsLocalOrFrom mdl) $  map getName instances
+                                                  ++ map getName fam_instances
 
-  maps@(!docMap, !argMap, !subMap, !declMap) <-
+  maps@(!docMap, !argMap, !subMap, !declMap, _) <-
     liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
 
   let exports0 = fmap (reverse . map unLoc) mayExports
@@ -90,16 +92,14 @@ createInterface tm flags modMap instIfaceMap = do
        | OptIgnoreExports `elem` opts = Nothing
        | otherwise = exports0
 
-  liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
-
   warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
   exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
-                   instances instIfaceMap dflags
+                   instIfaceMap dflags
 
-  let !visibleNames = mkVisibleNames exportItems opts
+  let !visibleNames = mkVisibleNames maps exportItems opts
 
   -- Measure haddock documentation coverage.
   let prunedExportItems0 = pruneExportItems exportItems
@@ -138,6 +138,7 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceSubMap          = subMap
   , ifaceModuleAliases   = aliases
   , ifaceInstances       = instances
+  , ifaceFamInstances    = fam_instances
   , ifaceHaddockCoverage = coverage
   , ifaceWarningMap      = warningMap
   }
@@ -242,33 +243,33 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 --------------------------------------------------------------------------------
 
 
-type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
+type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
 
 -- | Create 'Maps' by looping through the declarations. For each declaration,
 -- find its names, its subordinates, and its doc strings. Process doc strings
 -- into 'Doc's.
 mkMaps :: DynFlags
        -> GlobalRdrEnv
-       -> [ClsInst]
+       -> [Name]
        -> [(LHsDecl Name, [HsDocString])]
        -> ErrMsgM Maps
 mkMaps dflags gre instances decls = do
   (a, b, c, d) <- unzip4 <$> mapM mappings decls
-  return (f a, f b, f c, f d)
+  return (f a, f b, f c, f d, instanceMap)
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
 
     mappings (ldecl, docStrs) = do
-      let decl = unLoc ldecl
+      let L l decl = ldecl
       let declDoc strs m = do
             doc <- processDocStrings dflags gre strs
             m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
             return (doc, m')
       (doc, args) <- declDoc docStrs (typeDocs decl)
-      let subs = subordinates decl
+      let subs = subordinates instanceMap decl
       (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
-      let ns = names decl
+      let ns = names l decl
           subNs = [ n | (n, _, _) <- subs ]
           dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
           am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
@@ -282,11 +283,14 @@ mkMaps dflags gre instances decls = do
           return (dm, am, sm, cm)
 
     instanceMap :: Map SrcSpan Name
-    instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
+    instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
 
-    names :: HsDecl Name -> [Name]
-    names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap)  -- See note [2].
-    names decl = getMainDeclBinder decl
+    names :: SrcSpan -> HsDecl Name -> [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
+              _ -> getInstLoc d
+    names _ decl = getMainDeclBinder decl
 
 -- Note [2]:
 ------------
@@ -303,24 +307,29 @@ mkMaps dflags gre instances decls = do
 
 
 -- | Get all subordinate declarations inside a declaration, and their docs.
-subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates (TyClD decl)
-  | isClassDecl decl = classSubs
-  | isDataDecl  decl = dataSubs
+subordinates :: InstMap -> HsDecl Name -> [(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
+
+  InstD (DataFamInstD d)  -> dataSubs (dfid_defn d)
+  TyClD d | isClassDecl d -> classSubs d
+          | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
   where
-    classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl
-                , name <- getMainDeclBinder d, not (isValD d)
-                ]
-    dataSubs = constrs ++ fields
+    classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs dd = constrs ++ fields
       where
-        cons = map unL $ (dd_cons (tcdDataDefn decl))
+        cons = map unL $ (dd_cons dd)
         constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
                   | c <- cons ]
         fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
                   | RecCon flds <- map con_details cons
                   , ConDeclField n _ doc <- flds ]
-subordinates _ = []
-
 
 -- | Extract function argument docs from inside types.
 typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -390,38 +399,6 @@ sortByLoc :: [Located a] -> [Located a]
 sortByLoc = sortBy (comparing getLoc)
 
 
-warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
-warnAboutFilteredDecls dflags mdl decls = do
-  let modStr = moduleString mdl
-  let typeInstances =
-        nub (concat [[ unLoc (tfie_tycon (unLoc eqn))
-                     | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn }))) <- decls ],
-                     [ unLoc (dfid_tycon d)
-                     | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ],
-                     [ unLoc tc
-                     | L _ (TyClD (FamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _
-                                                       , fdLName = tc }))) <- decls ]])
-
-  unless (null typeInstances) $
-    tell [
-      "Warning: " ++ modStr ++ ": Instances of type and data "
-      ++ "families and equations of closed type families are not yet supported."
-      ++ "Instances of the following families "
-      ++ "will be filtered out:\n  " ++ (intercalate ", "
-      $ map (occNameString . nameOccName) typeInstances) ]
-
-  let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl
-                                                { cid_poly_ty = i
-                                                , cid_tyfam_insts = ats
-                                                , cid_datafam_insts = adts }))) <- decls
-                                 , not (null ats) || not (null adts) ]
-
-  unless (null instances) $
-    tell [
-      "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
-      ++ "These instances are affected:\n" ++ intercalate ", " instances ]
-
-
 --------------------------------------------------------------------------------
 -- Filtering of declarations
 --
@@ -493,20 +470,16 @@ mkExportItems
   -> [LHsDecl Name]
   -> Maps
   -> Maybe [IE Name]
-  -> [ClsInst]
   -> InstIfaceMap
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod warnings gre exportedNames decls0
-  (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
+  modMap thisMod warnings gre exportedNames decls
+  (maps@(docMap, argMap, subMap, declMap, instMap)) optExports instIfaceMap dflags =
   case optExports of
     Nothing -> fullModuleContents dflags warnings gre maps decls
     Just exports -> liftM concat $ mapM lookupExport exports
   where
-    decls = filter (not . isInstD . unLoc) decls0
-
-
     lookupExport (IEVar x)             = declWith x
     lookupExport (IEThingAbs t)        = declWith t
     lookupExport (IEThingAll t)        = declWith t
@@ -585,7 +558,7 @@ mkExportItems
                 Nothing -> do
                    liftErrMsg $ tell
                       ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
-                   let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
+                   let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
                    return [ mkExportDecl t decl (noDocForDecl, subs_) ]
                 Just iface ->
                    return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
@@ -710,7 +683,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
 
 
 fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) decls =
   liftM catMaybes $ mapM mkExportItem (expandSig decls)
   where
     -- A type signature can have multiple names, like:
@@ -739,6 +712,10 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
           let (doc, _) = lookupDocs name warnings docMap argMap subMap in
           fmap Just (hiValExportItem dflags name doc)
       | otherwise = return Nothing
+    mkExportItem decl@(L _ (InstD d))
+      | Just name <- M.lookup (getInstLoc d) instMap =
+        let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
+        return $ Just (ExportDecl decl doc subs [])
     mkExportItem decl
       | name:_ <- getMainDeclBinder (unLoc decl) =
         let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
@@ -809,14 +786,17 @@ pruneExportItems = filter hasDoc
     hasDoc _ = True
 
 
-mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
-mkVisibleNames exports opts
+mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames (_, _, _, _, instMap) exports opts
   | OptHide `elem` opts = []
   | otherwise = let ns = concatMap exportName exports
                 in seqList ns `seq` ns
   where
-    exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
+    exportName e@ExportDecl {} = name ++ subs
       where subs = map fst (expItemSubDocs e)
+            name = case unLoc $ expItemDecl e of
+              InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
+              decl    -> getMainDeclBinder decl
     exportName ExportNoDecl {} = [] -- we don't count these as visible, since
                                     -- we don't want links to go to them.
     exportName _ = []
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b4a7e19a..de23e9b5 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -258,11 +258,14 @@ renameLContext (L loc context) = do
 
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (preds, className, types) = do
-  preds' <- mapM renameType preds
+renameInstHead (className, types, rest) = do
   className' <- rename className
   types' <- mapM renameType types
-  return (preds', className', types')
+  rest' <- case rest of
+    ClassInst cs -> ClassInst <$> mapM renameType cs
+    TypeInst  ts -> TypeInst  <$> renameType ts
+    DataInst  dd -> DataInst  <$> renameTyClD dd
+  return (className', types', rest')
 
 
 renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 0a633ec0..0e7f83af 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -23,7 +23,7 @@ module Haddock.Types (
 import Data.Foldable
 import Data.Traversable
 import Control.Exception
-import Control.Arrow
+import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
 import Data.Typeable
 import Data.Map (Map)
@@ -31,6 +31,7 @@ import qualified Data.Map as Map
 import GHC hiding (NoLink)
 import DynFlags (ExtensionFlag, Language)
 import OccName
+import Outputable
 import Control.Applicative (Applicative(..))
 import Control.Monad (ap)
 
@@ -45,6 +46,7 @@ type DocMap a      = Map Name (Doc a)
 type ArgMap a      = Map Name (Map Int (Doc a))
 type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
+type InstMap       = Map SrcSpan Name
 type SrcMap        = Map PackageId FilePath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
@@ -112,6 +114,7 @@ data Interface = Interface
 
     -- | Instances exported by the module.
   , ifaceInstances       :: ![ClsInst]
+  , ifaceFamInstances    :: ![FamInst]
 
     -- | The number of haddockable and haddocked items in the module, as a
     -- tuple. Haddockable items are the exports and the module itself.
@@ -273,14 +276,23 @@ instance NamedThing DocName where
 -- * Instances
 -----------------------------------------------------------------------------
 
+-- | The three types of instances
+data InstType name
+  = ClassInst [HsType name]  -- ^ Context
+  | TypeInst  (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
+  ppr (TypeInst  a) = text "TypeInst"  <+> ppr a
+  ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
 -- | An instance head that may have documentation.
 type DocInstance name = (InstHead name, Maybe (Doc name))
 
-
--- | The head of an instance. Consists of a context, a class name and a list
--- of instance types.
-type InstHead name = ([HsType name], name, [HsType name])
+-- | The head of an instance. Consists of a class name, a list of parameters
+-- and an instance type
+type InstHead name = (name, [HsType name], InstType name)
 
 -----------------------------------------------------------------------------
 -- * Documentation comments