Use Cxt for deriving clauses in TH (#10819)

Summary:
Deriving clauses in the TH representations of data, newtype, data
instance, and newtype instance declarations previously were just [Name],
which didn't allow for more complex derived classes, eg. multi-parameter
typeclasses.

This switches out [Name] for Cxt, representing the derived classes as
types instead of names.

Test Plan: validate

Reviewers: goldfire, spinda, austin

Reviewed By: goldfire, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1202

GHC Trac Issues: #10819

compiler/deSugar/DsMeta.hs

@@ -763,19 +763,19 @@ repBangTy ty = do
 --                      Deriving clause
 -------------------------------------------------------
 
-repDerivs :: HsDeriving Name -> DsM (Core [TH.Name])
-repDerivs Nothing = coreList nameTyConName []
-repDerivs (Just (L _ ctxt))
-  = repList nameTyConName (rep_deriv . hsSigType) ctxt
+repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
+repDerivs deriv = do
+    let clauses
+          | Nothing <- deriv         = []
+          | Just (L _ ctxt) <- deriv = ctxt
+    tys <- repList typeQTyConName
+                   (rep_deriv . hsSigType)
+                   clauses
+           :: DsM (Core [TH.PredQ])
+    repCtxt tys
   where
-    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-        -- Deriving clauses must have the simple H98 form
-    rep_deriv ty
-      | Just (L _ cls, []) <- hsTyGetAppHead_maybe ty
-      = lookupOcc cls
-      | otherwise
-      = notHandled "Non-H98 deriving clause" (ppr ty)
-
+    rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
+    rep_deriv (L _ ty) = repTy ty
 
 -------------------------------------------------------
 --   Signatures in a class decl, or a group of bindings
@@ -1937,7 +1937,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
         -> Maybe (Core [TH.TypeQ])
-        -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
+        -> Core [TH.ConQ] -> Core TH.CxtQ -> DsM (Core TH.DecQ)
 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
   = rep2 dataDName [cxt, nm, tvs, cons, derivs]
 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
@@ -1945,7 +1945,7 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
 
 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
-           -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
+           -> Core TH.ConQ -> Core TH.CxtQ -> DsM (Core TH.DecQ)
 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
   = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)

compiler/hsSyn/Convert.hs

@@ -481,14 +481,12 @@ cvt_id_arg (i, str, ty)
                                        , cd_fld_type =  ty'
                                        , cd_fld_doc = Nothing}) }
 
-cvtDerivs :: [TH.Name] -> CvtM (HsDeriving RdrName)
+cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
 cvtDerivs [] = return Nothing
-cvtDerivs cs = do { cs' <- mapM cvt_one cs
-                  ; return (Just (noLoc cs')) }
-        where
-          cvt_one c = do { c' <- tconName c
-                         ; ty <- returnL $ HsTyVar (noLoc c')
-                         ; return (mkLHsSigType ty) }
+cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
+  where
+    mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
+    mkSigTypes = fmap (map mkLHsSigType)
 
 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs

docs/users_guide/7.12.1-notes.rst

@@ -284,6 +284,12 @@ Template Haskell
    of ``FamilyD``. Common elements of ``OpenTypeFamilyD`` and
    ``ClosedTypeFamilyD`` have been moved to ``TypeFamilyHead``.
 
+-  The representation of ``data``, ``newtype``, ``data instance``, and
+   ``newtype instance`` declarations has been changed to allow for
+   multi-parameter type classes in the ``deriving`` clause. In particular,
+   ``dataD`` and ``newtypeD`` now take a ``CxtQ`` instead of a ``[Name]``
+   for the list of derived classes.
+
 Runtime system
 ~~~~~~~~~~~~~~
 

libraries/template-haskell/Language/Haskell/TH/Lib.hs

@@ -338,19 +338,21 @@ funD nm cs =
 tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
 
-dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
+dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ
 dataD ctxt tc tvs cons derivs =
   do
     ctxt1 <- ctxt
     cons1 <- sequence cons
-    return (DataD ctxt1 tc tvs cons1 derivs)
+    derivs1 <- derivs
+    return (DataD ctxt1 tc tvs cons1 derivs1)
 
-newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ
+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> CxtQ -> DecQ
 newtypeD ctxt tc tvs con derivs =
   do
     ctxt1 <- ctxt
     con1 <- con
-    return (NewtypeD ctxt1 tc tvs con1 derivs)
+    derivs1 <- derivs
+    return (NewtypeD ctxt1 tc tvs con1 derivs1)
 
 classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
 classD ctxt cls tvs fds decs =
@@ -423,21 +425,23 @@ pragAnnD target expr
 pragLineD :: Int -> String -> DecQ
 pragLineD line file = return $ PragmaD $ LineP line file
 
-dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
+dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> CxtQ -> DecQ
 dataInstD ctxt tc tys cons derivs =
   do
     ctxt1 <- ctxt
     tys1  <- sequence tys
     cons1 <- sequence cons
-    return (DataInstD ctxt1 tc tys1 cons1 derivs)
+    derivs1 <- derivs
+    return (DataInstD ctxt1 tc tys1 cons1 derivs1)
 
-newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ
+newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> CxtQ -> DecQ
 newtypeInstD ctxt tc tys con derivs =
   do
     ctxt1 <- ctxt
     tys1  <- sequence tys
     con1  <- con
-    return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
+    derivs1 <- derivs
+    return (NewtypeInstD ctxt1 tc tys1 con1 derivs1)
 
 tySynInstD :: Name -> TySynEqnQ -> DecQ
 tySynInstD tc eqn =

libraries/template-haskell/Language/Haskell/TH/Ppr.hs

@@ -339,7 +339,7 @@ ppr_dec _ (StandaloneDerivD cxt ty)
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
 
-ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
+ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> Cxt -> Doc
 ppr_data maybeInst ctxt t argsDoc cs decs
   = sep [text "data" <+> maybeInst
             <+> pprCxt ctxt
@@ -348,14 +348,13 @@ ppr_data maybeInst ctxt t argsDoc cs decs
          if null decs
            then empty
            else nest nestDepth
-              $ text "deriving"
-                <+> parens (hsep $ punctuate comma $ map ppr decs)]
+              $ text "deriving" <+> ppr_cxt_preds decs]
   where
     pref :: [Doc] -> [Doc]
     pref []     = []      -- No constructors; can't happen in H98
     pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
 
-ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc
+ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> Cxt -> Doc
 ppr_newtype maybeInst ctxt t argsDoc c decs
   = sep [text "newtype" <+> maybeInst
             <+> pprCxt ctxt
@@ -364,8 +363,7 @@ ppr_newtype maybeInst ctxt t argsDoc c decs
          if null decs
            then empty
            else nest nestDepth
-                $ text "deriving"
-                  <+> parens (hsep $ punctuate comma $ map ppr decs)]
+                $ text "deriving" <+> ppr_cxt_preds decs]
 
 ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
@@ -588,8 +586,12 @@ instance Ppr Role where
 ------------------------------
 pprCxt :: Cxt -> Doc
 pprCxt [] = empty
-pprCxt [t] = ppr t <+> text "=>"
-pprCxt ts = parens (sep $ punctuate comma $ map ppr ts) <+> text "=>"
+pprCxt ts = ppr_cxt_preds ts <+> text "=>"
+
+ppr_cxt_preds :: Cxt -> Doc
+ppr_cxt_preds [] = empty
+ppr_cxt_preds [t] = ppr t
+ppr_cxt_preds ts = parens (sep $ punctuate comma $ map ppr ts)
 
 ------------------------------
 instance Ppr Range where

libraries/template-haskell/Language/Haskell/TH/Syntax.hs

@@ -1453,11 +1453,11 @@ data Dec
   = FunD Name [Clause]            -- ^ @{ f p1 p2 = b where decs }@
   | ValD Pat Body [Dec]           -- ^ @{ p = b where decs }@
   | DataD Cxt Name [TyVarBndr]
-         [Con] [Name]             -- ^ @{ data Cxt x => T x = A x | B (T x)
-                                  --       deriving (Z,W)}@
+         [Con] Cxt                -- ^ @{ data Cxt x => T x = A x | B (T x)
+                                  --       deriving (Z,W Q)}@
   | NewtypeD Cxt Name [TyVarBndr]
-         Con [Name]               -- ^ @{ newtype Cxt x => T x = A (B x)
-                                  --       deriving (Z,W)}@
+         Con Cxt                  -- ^ @{ newtype Cxt x => T x = A (B x)
+                                  --       deriving (Z,W Q)}@
   | TySynD Name [TyVarBndr] Type  -- ^ @{ type T x = (x,x) }@
   | ClassD Cxt Name [TyVarBndr]
          [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@
@@ -1478,11 +1478,11 @@ data Dec
          -- ^ @{ data family T a b c :: * }@
 
   | DataInstD Cxt Name [Type]
-         [Con] [Name]             -- ^ @{ data instance Cxt x => T [x] = A x
+         [Con] Cxt                -- ^ @{ data instance Cxt x => T [x] = A x
                                   --                                | B (T x)
-                                  --       deriving (Z,W)}@
+                                  --       deriving (Z,W Q)}@
   | NewtypeInstD Cxt Name [Type]
-         Con [Name]               -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
+         Con Cxt                  -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
                                   --       deriving (Z,W)}@
   | TySynInstD Name TySynEqn      -- ^ @{ type instance ... }@
 

testsuite/tests/rts/T7919A.hs

@@ -16,11 +16,11 @@ stepName = mkName "step"
 -- data Large = Large Int ... Int  -- generate 'size' fields, not strict
 largeData =
   dataD
-    (return [])
+    (cxt [])
     (dataName)
     []
     [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))]
-    []
+    (cxt [])
 
 conE' :: Name -> [ExpQ] -> ExpQ
 conE' n es = foldl appE (conE n) es

testsuite/tests/th/T10819.hs

+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module T10819 where
+
+import T10819_Lib
+
+import Language.Haskell.TH.Syntax
+
+class C a b | b -> a where
+  f :: b -> a
+
+data D = X
+
+instance C Int D where
+  f X = 2
+
+$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")])
+
+thing :: N
+thing = N X
+
+thing1 :: Int
+thing1 = f thing

testsuite/tests/th/T10819_Lib.hs

+module T10819_Lib where
+
+import Language.Haskell.TH.Syntax
+
+doSomeTH s tp drv = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) drv]
+  where n = mkName s

testsuite/tests/th/TH_dataD1.hs

@@ -5,7 +5,7 @@ import Language.Haskell.TH
 
 ds :: Q [Dec]
 ds = [d|
-          $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] []
+          $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] (cxt [])
                ; return [d]})
        |]
 

testsuite/tests/th/all.T

@@ -365,4 +365,7 @@ test('T10891', normal, compile, ['-v0'])
 test('T10945', normal, compile_fail, ['-v0'])
 test('T10946', expect_broken(10946), compile, ['-v0'])
 test('T10734', normal, compile_and_run, ['-v0'])
-
+test('T10819',
+     extra_clean(['T10819_Lib.hi', 'T10819_Lib.o']),
+     multimod_compile,
+     ['T10819.hs', '-v0 ' + config.ghc_th_way_flags])