diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-05-14 14:41:28 -0400 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-05-22 17:24:32 -0400 |
| commit | 273d5aa8d4a3208879192aeca3b9f1a8245a3c3e (patch) | |
| tree | 5c740198fd0002220e0de10e6a3a32e1815c67e0 | |
| parent | 103a894471b18c9c3b0d9faffe2420e10b420686 (diff) | |
Match changes with #14332
| -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 |