diff options
| -rw-r--r-- | compiler/deSugar/ExtractDocs.hs | 17 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 4 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/T14332.hs | 14 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr | 2 | ||||
| m--------- | utils/haddock | 0 |
7 files changed, 40 insertions, 5 deletions
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 4a5e890553..f608424d7d 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -191,11 +191,22 @@ subordinates instMap decl = case decl of , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (dL->L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) - | HsIB { hsib_body = (dL->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 diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index c2dae02afc..087474f9af 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2086,9 +2086,9 @@ inst_type :: { LHsSigType GhcPs } : sigtype { mkLHsSigType $1 } deriv_types :: { [LHsSigType GhcPs] } - : typedoc { [mkLHsSigType $1] } + : ktypedoc { [mkLHsSigType $1] } - | typedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) + | ktypedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) >> return (mkLHsSigType $1 : $3) } comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty diff --git a/testsuite/tests/deriving/should_compile/T14332.hs b/testsuite/tests/deriving/should_compile/T14332.hs new file mode 100644 index 0000000000..daffd17a79 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T14332.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +module T14332 where + +import Data.Kind + +class C a b + +data D a = D + deriving ( forall a. C a + , Show :: Type -> Constraint + ) diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index a5f666c062..1c1b4d546a 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -102,6 +102,7 @@ test('T14045b', normal, compile, ['']) test('T14094', normal, compile, ['']) test('T14339', normal, compile, ['']) test('T14331', normal, compile, ['']) +test('T14332', normal, compile, ['']) test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques']) test('T14579', normal, compile, ['-ddump-deriv -dsuppress-uniques']) test('T14579a', normal, compile, ['']) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs index 5689b42380..5e7369cdc0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module T11768 where +class C a b + data Foo = Foo deriving Eq -- ^ Documenting a single type @@ -8,6 +14,7 @@ data Bar = Bar deriving ( Eq -- ^ Documenting one of multiple types , Ord ) + deriving anyclass ( forall a. C a {- ^ Documenting forall type -} ) -- | Documenting a standalone deriving instance deriving instance Read Bar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 997c2ef24c..6de1b2b851 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -1,12 +1,14 @@ ==================== Parser ==================== module T11768 where +class C a b data Foo = Foo deriving Eq " Documenting a single type" data Bar = Bar deriving (Eq " Documenting one of multiple types", Ord) + deriving anyclass (forall a. C a " Documenting forall type ") <document comment> deriving instance Read Bar diff --git a/utils/haddock b/utils/haddock -Subproject 103a894471b18c9c3b0d9faffe2420e10b42068 +Subproject 273d5aa8d4a3208879192aeca3b9f1a8245a3c3 |