aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs18
1 files changed, 15 insertions, 3 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index a63f44ce..f17f3d7f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -467,11 +468,22 @@ subordinates instMap decl = case decl of
, L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
- | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
- <- concatMap (unLoc . deriv_clause_tys . unLoc) $
- unLoc $ dd_derivs dd
+ | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
+ concatMap (unLoc . deriv_clause_tys . unLoc) $
+ unLoc $ dd_derivs dd
, Just instName <- [M.lookup l instMap] ]
+ extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
+ extract_deriv_ty ty =
+ case dL ty of
+ -- deriving (forall a. C a {- ^ Doc comment -})
+ L l (HsForAllTy{ hst_fvf = ForallInvis
+ , hst_body = dL->L _ (HsDocTy _ _ doc) })
+ -> Just (l, doc)
+ -- deriving (C a {- ^ Doc comment -})
+ L l (HsDocTy _ _ doc) -> Just (l, doc)
+ _ -> Nothing
+
-- | Extract constructor argument docs from inside constructor decls.
conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
conArgDocs con = case getConArgs con of