diff options
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 18 |
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 |