Some forall-related cleanup in deriving code
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 14 May 2019 19:04:02 +0000 (15:04 -0400)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Fri, 24 May 2019 02:43:12 +0000 (22:43 -0400)
* Tweak the parser to allow `deriving` clauses to mention explicit
  `forall`s or kind signatures without gratuitous parentheses.
  (This fixes #14332 as a consequence.)
* Allow Haddock comments on `deriving` clauses with explicit
  `forall`s. This requires corresponding changes in Haddock.

compiler/deSugar/ExtractDocs.hs
compiler/parser/Parser.y
testsuite/tests/deriving/should_compile/T14332.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T
testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs
testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr
utils/haddock

index 4a5e890..f608424 100644 (file)
@@ -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
index c2dae02..087474f 100644 (file)
@@ -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 (file)
index 0000000..daffd17
--- /dev/null
@@ -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
+           )
index a5f666c..1c1b4d5 100644 (file)
@@ -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, [''])
index 5689b42..5e7369c 100644 (file)
@@ -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
index 997c2ef..6de1b2b 100644 (file)
@@ -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
 
index 103a894..273d5aa 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 103a894471b18c9c3b0d9faffe2420e10b420686
+Subproject commit 273d5aa8d4a3208879192aeca3b9f1a8245a3c3e