From 273d5aa8d4a3208879192aeca3b9f1a8245a3c3e Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Tue, 14 May 2019 14:41:28 -0400
Subject: Match changes with #14332
---
haddock-api/src/Haddock/Interface/Create.hs | 18 +++++++++++++++---
1 file changed, 15 insertions(+), 3 deletions(-)
(limited to 'haddock-api/src/Haddock/Interface')
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
--
cgit v1.2.3