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
-- 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)
......
......@@ -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
......
......@@ -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
~~~~~~~~~~~~~~
......
......@@ -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 =
......
......@@ -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
......
......@@ -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 ... }@
......
......@@ -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
......
{-# 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
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]})
|]
......@@ -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])
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