Commit 04ab55d9 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

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
parent 65920c9e
...@@ -763,19 +763,19 @@ repBangTy ty = do ...@@ -763,19 +763,19 @@ repBangTy ty = do
-- Deriving clause -- Deriving clause
------------------------------------------------------- -------------------------------------------------------
repDerivs :: HsDeriving Name -> DsM (Core [TH.Name]) repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
repDerivs Nothing = coreList nameTyConName [] repDerivs deriv = do
repDerivs (Just (L _ ctxt)) let clauses
= repList nameTyConName (rep_deriv . hsSigType) ctxt | Nothing <- deriv = []
| Just (L _ ctxt) <- deriv = ctxt
tys <- repList typeQTyConName
(rep_deriv . hsSigType)
clauses
:: DsM (Core [TH.PredQ])
repCtxt tys
where where
rep_deriv :: LHsType Name -> DsM (Core TH.Name) rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
-- Deriving clauses must have the simple H98 form rep_deriv (L _ ty) = repTy ty
rep_deriv ty
| Just (L _ cls, []) <- hsTyGetAppHead_maybe ty
= lookupOcc cls
| otherwise
= notHandled "Non-H98 deriving clause" (ppr ty)
------------------------------------------------------- -------------------------------------------------------
-- Signatures in a class decl, or a group of bindings -- Signatures in a class decl, or a group of bindings
...@@ -1937,7 +1937,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] ...@@ -1937,7 +1937,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> 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) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, cons, derivs] = rep2 dataDName [cxt, nm, tvs, cons, derivs]
repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC 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) ...@@ -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] repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> 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) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, con, derivs] = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
......
...@@ -481,14 +481,12 @@ cvt_id_arg (i, str, ty) ...@@ -481,14 +481,12 @@ cvt_id_arg (i, str, ty)
, cd_fld_type = ty' , cd_fld_type = ty'
, cd_fld_doc = Nothing}) } , cd_fld_doc = Nothing}) }
cvtDerivs :: [TH.Name] -> CvtM (HsDeriving RdrName) cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
cvtDerivs [] = return Nothing cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
; return (Just (noLoc cs')) } where
where mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
cvt_one c = do { c' <- tconName c mkSigTypes = fmap (map mkLHsSigType)
; ty <- returnL $ HsTyVar (noLoc c')
; return (mkLHsSigType ty) }
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
......
...@@ -284,6 +284,12 @@ Template Haskell ...@@ -284,6 +284,12 @@ Template Haskell
of ``FamilyD``. Common elements of ``OpenTypeFamilyD`` and of ``FamilyD``. Common elements of ``OpenTypeFamilyD`` and
``ClosedTypeFamilyD`` have been moved to ``TypeFamilyHead``. ``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 Runtime system
~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~
......
...@@ -338,19 +338,21 @@ funD nm cs = ...@@ -338,19 +338,21 @@ funD nm cs =
tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } 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 = dataD ctxt tc tvs cons derivs =
do do
ctxt1 <- ctxt ctxt1 <- ctxt
cons1 <- sequence cons 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 = newtypeD ctxt tc tvs con derivs =
do do
ctxt1 <- ctxt ctxt1 <- ctxt
con1 <- con 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 :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
classD ctxt cls tvs fds decs = classD ctxt cls tvs fds decs =
...@@ -423,21 +425,23 @@ pragAnnD target expr ...@@ -423,21 +425,23 @@ pragAnnD target expr
pragLineD :: Int -> String -> DecQ pragLineD :: Int -> String -> DecQ
pragLineD line file = return $ PragmaD $ LineP line file 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 = dataInstD ctxt tc tys cons derivs =
do do
ctxt1 <- ctxt ctxt1 <- ctxt
tys1 <- sequence tys tys1 <- sequence tys
cons1 <- sequence cons 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 = newtypeInstD ctxt tc tys con derivs =
do do
ctxt1 <- ctxt ctxt1 <- ctxt
tys1 <- sequence tys tys1 <- sequence tys
con1 <- con con1 <- con
return (NewtypeInstD ctxt1 tc tys1 con1 derivs) derivs1 <- derivs
return (NewtypeInstD ctxt1 tc tys1 con1 derivs1)
tySynInstD :: Name -> TySynEqnQ -> DecQ tySynInstD :: Name -> TySynEqnQ -> DecQ
tySynInstD tc eqn = tySynInstD tc eqn =
......
...@@ -339,7 +339,7 @@ ppr_dec _ (StandaloneDerivD cxt ty) ...@@ -339,7 +339,7 @@ ppr_dec _ (StandaloneDerivD cxt ty)
ppr_dec _ (DefaultSigD n ty) ppr_dec _ (DefaultSigD n ty)
= hsep [ text "default", pprPrefixOcc n, dcolon, ppr 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 ppr_data maybeInst ctxt t argsDoc cs decs
= sep [text "data" <+> maybeInst = sep [text "data" <+> maybeInst
<+> pprCxt ctxt <+> pprCxt ctxt
...@@ -348,14 +348,13 @@ ppr_data maybeInst ctxt t argsDoc cs decs ...@@ -348,14 +348,13 @@ ppr_data maybeInst ctxt t argsDoc cs decs
if null decs if null decs
then empty then empty
else nest nestDepth else nest nestDepth
$ text "deriving" $ text "deriving" <+> ppr_cxt_preds decs]
<+> parens (hsep $ punctuate comma $ map ppr decs)]
where where
pref :: [Doc] -> [Doc] pref :: [Doc] -> [Doc]
pref [] = [] -- No constructors; can't happen in H98 pref [] = [] -- No constructors; can't happen in H98
pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds 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 ppr_newtype maybeInst ctxt t argsDoc c decs
= sep [text "newtype" <+> maybeInst = sep [text "newtype" <+> maybeInst
<+> pprCxt ctxt <+> pprCxt ctxt
...@@ -364,8 +363,7 @@ ppr_newtype maybeInst ctxt t argsDoc c decs ...@@ -364,8 +363,7 @@ ppr_newtype maybeInst ctxt t argsDoc c decs
if null decs if null decs
then empty then empty
else nest nestDepth else nest nestDepth
$ text "deriving" $ text "deriving" <+> ppr_cxt_preds decs]
<+> parens (hsep $ punctuate comma $ map ppr decs)]
ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
ppr_tySyn maybeInst t argsDoc rhs ppr_tySyn maybeInst t argsDoc rhs
...@@ -588,8 +586,12 @@ instance Ppr Role where ...@@ -588,8 +586,12 @@ instance Ppr Role where
------------------------------ ------------------------------
pprCxt :: Cxt -> Doc pprCxt :: Cxt -> Doc
pprCxt [] = empty pprCxt [] = empty
pprCxt [t] = ppr t <+> text "=>" pprCxt ts = ppr_cxt_preds ts <+> text "=>"
pprCxt ts = parens (sep $ punctuate comma $ map ppr 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 instance Ppr Range where
......
...@@ -1453,11 +1453,11 @@ data Dec ...@@ -1453,11 +1453,11 @@ data Dec
= FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@
| ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@
| DataD Cxt Name [TyVarBndr] | DataD Cxt Name [TyVarBndr]
[Con] [Name] -- ^ @{ data Cxt x => T x = A x | B (T x) [Con] Cxt -- ^ @{ data Cxt x => T x = A x | B (T x)
-- deriving (Z,W)}@ -- deriving (Z,W Q)}@
| NewtypeD Cxt Name [TyVarBndr] | NewtypeD Cxt Name [TyVarBndr]
Con [Name] -- ^ @{ newtype Cxt x => T x = A (B x) Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x)
-- deriving (Z,W)}@ -- deriving (Z,W Q)}@
| TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@
| ClassD Cxt Name [TyVarBndr] | ClassD Cxt Name [TyVarBndr]
[FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
...@@ -1478,11 +1478,11 @@ data Dec ...@@ -1478,11 +1478,11 @@ data Dec
-- ^ @{ data family T a b c :: * }@ -- ^ @{ data family T a b c :: * }@
| DataInstD Cxt Name [Type] | 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) -- | B (T x)
-- deriving (Z,W)}@ -- deriving (Z,W Q)}@
| NewtypeInstD Cxt Name [Type] | 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)}@ -- deriving (Z,W)}@
| TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@
......
...@@ -16,11 +16,11 @@ stepName = mkName "step" ...@@ -16,11 +16,11 @@ stepName = mkName "step"
-- data Large = Large Int ... Int -- generate 'size' fields, not strict -- data Large = Large Int ... Int -- generate 'size' fields, not strict
largeData = largeData =
dataD dataD
(return []) (cxt [])
(dataName) (dataName)
[] []
[normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))] [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))]
[] (cxt [])
conE' :: Name -> [ExpQ] -> ExpQ conE' :: Name -> [ExpQ] -> ExpQ
conE' n es = foldl appE (conE n) es conE' n es = foldl appE (conE n) es
......
{-# 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
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
...@@ -5,7 +5,7 @@ import Language.Haskell.TH ...@@ -5,7 +5,7 @@ import Language.Haskell.TH
ds :: Q [Dec] ds :: Q [Dec]
ds = [d| ds = [d|
$(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] [] $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] (cxt [])
; return [d]}) ; return [d]})
|] |]
...@@ -365,4 +365,7 @@ test('T10891', normal, compile, ['-v0']) ...@@ -365,4 +365,7 @@ test('T10891', normal, compile, ['-v0'])
test('T10945', normal, compile_fail, ['-v0']) test('T10945', normal, compile_fail, ['-v0'])
test('T10946', expect_broken(10946), compile, ['-v0']) test('T10946', expect_broken(10946), compile, ['-v0'])
test('T10734', normal, compile_and_run, ['-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])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment