[commit: ghc] master: reify associated types when reifying typeclasses(#10891) (b4d43b4)
git at git.haskell.org
git at git.haskell.org
Sat Sep 26 19:27:11 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/b4d43b4e9f4f4fba068ab1e132113c4cd305dfe3/ghc
>---------------------------------------------------------------
commit b4d43b4e9f4f4fba068ab1e132113c4cd305dfe3
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date: Sat Sep 26 21:07:51 2015 +0200
reify associated types when reifying typeclasses(#10891)
As reported in Trac #10891, Template Haskell's `reify` was not
generating Decls for associated types. This patch fixes that.
Note that even though `reifyTyCon` function used in this patch returns
some type instances, I'm ignoring that.
Here's an example of how associated types are encoded with this patch:
(Simplified representation)
class C a where
type F a :: *
-->
OpenTypeFamilyD "F" ["a"]
With default type instances:
class C a where
type F a :: *
type F a = a
-->
OpenTypeFamilyD "F" ["a"]
TySynInstD "F" (TySynEqn [VarT "a"] "a")
Test Plan:
This patch was already reviewed and even merged. The patch is later
reverted because apparently it broke the build some time between the
validation of this patch and merge. Creating this new ticket to fix the
validation.
Reviewers: goldfire, austin, bgamari
Reviewed By: bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1277
GHC Trac Issues: #10891
>---------------------------------------------------------------
b4d43b4e9f4f4fba068ab1e132113c4cd305dfe3
compiler/typecheck/TcSplice.hs | 28 +++++++++++++++++++++--
testsuite/tests/th/T10891.hs | 39 +++++++++++++++++++++++++++++++++
testsuite/tests/th/T10891.stderr | 12 ++++++++++
testsuite/tests/th/TH_reifyDecl1.stderr | 2 ++
testsuite/tests/th/all.T | 1 +
5 files changed, 80 insertions(+), 2 deletions(-)
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 2a21705..c8eb9f8 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1202,12 +1202,13 @@ reifyClass cls
= do { cxt <- reifyCxt theta
; inst_envs <- tcGetInstEnvs
; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
+ ; assocTys <- concatMapM reifyAT ats
; ops <- concatMapM reify_op op_stuff
; tvs' <- reifyTyVars tvs
- ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
+ ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
; return (TH.ClassI dec insts) }
where
- (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
+ (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
reify_op (op, def_meth)
= do { ty <- reifyType (idType op)
@@ -1219,6 +1220,29 @@ reifyClass cls
; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
_ -> return [TH.SigD nm' ty] }
+ reifyAT :: ClassATItem -> TcM [TH.Dec]
+ reifyAT (ATI tycon def) = do
+ tycon' <- reifyTyCon tycon
+ case tycon' of
+ TH.FamilyI dec _ -> do
+ let (tyName, tyArgs) = tfNames dec
+ (dec :) <$> maybe (return [])
+ (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
+ def
+ _ -> pprPanic "reifyAT" (text (show tycon'))
+
+ reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
+ reifyDefImpl n args ty =
+ TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
+
+ tfNames :: TH.Dec -> (TH.Name, [TH.Name])
+ tfNames (TH.OpenTypeFamilyD n args _ _) = (n, map bndrName args)
+ tfNames d = pprPanic "tfNames" (text (show d))
+
+ bndrName :: TH.TyVarBndr -> TH.Name
+ bndrName (TH.PlainTV n) = n
+ bndrName (TH.KindedTV n _) = n
+
------------------------------
-- | Annotate (with TH.SigT) a type if the first parameter is True
-- and if the type contains a free variable.
diff --git a/testsuite/tests/th/T10891.hs b/testsuite/tests/th/T10891.hs
new file mode 100644
index 0000000..d91caf9
--- /dev/null
+++ b/testsuite/tests/th/T10891.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T10891 where
+
+import Language.Haskell.TH
+import System.IO
+
+class C a where
+ f :: a -> Int
+
+class C' a where
+ type F a :: *
+ type F a = a
+ f' :: a -> Int
+
+class C'' a where
+ data Fd a :: *
+
+instance C' Int where
+ type F Int = Bool
+ f' = id
+
+instance C'' Int where
+ data Fd Int = B Bool | C Char
+
+$(return [])
+
+test :: ()
+test =
+ $(let
+ display :: Name -> Q ()
+ display q = do
+ i <- reify q
+ runIO (hPutStrLn stderr (pprint i) >> hFlush stderr)
+ in do
+ display ''C
+ display ''C'
+ display ''C''
+ [| () |])
diff --git a/testsuite/tests/th/T10891.stderr b/testsuite/tests/th/T10891.stderr
new file mode 100644
index 0000000..874f4f0
--- /dev/null
+++ b/testsuite/tests/th/T10891.stderr
@@ -0,0 +1,12 @@
+class T10891.C (a_0 :: *)
+ where T10891.f :: forall (a_0 :: *) . T10891.C a_0 =>
+ a_0 -> GHC.Types.Int
+class T10891.C' (a_0 :: *)
+ where type T10891.F (a_0 :: *) :: *
+ type T10891.F a_0 = a_0
+ T10891.f' :: forall (a_0 :: *) . T10891.C' a_0 =>
+ a_0 -> GHC.Types.Int
+instance T10891.C' GHC.Types.Int
+class T10891.C'' (a_0 :: *)
+ where data T10891.Fd (a_0 :: *) :: *
+instance T10891.C'' GHC.Types.Int
diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr
index 503f533..e655587 100644
--- a/testsuite/tests/th/TH_reifyDecl1.stderr
+++ b/testsuite/tests/th/TH_reifyDecl1.stderr
@@ -20,6 +20,8 @@ class TH_reifyDecl1.C2 (a_0 :: *)
a_0 -> GHC.Types.Int
instance TH_reifyDecl1.C2 GHC.Types.Int
class TH_reifyDecl1.C3 (a_0 :: *)
+ where type TH_reifyDecl1.AT1 (a_0 :: *) :: *
+ data TH_reifyDecl1.AT2 (a_0 :: *) :: *
instance TH_reifyDecl1.C3 GHC.Types.Int
type family TH_reifyDecl1.AT1 (a_0 :: *) :: *
type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index f72cc30..9d4736c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -359,3 +359,4 @@ test('T6018th', normal, compile_fail, ['-v0'])
test('TH_namePackage', normal, compile_and_run, ['-v0'])
test('T10811', normal, compile, ['-v0'])
test('T10810', normal, compile, ['-v0'])
+test('T10891', normal, compile, ['-v0'])
More information about the ghc-commits
mailing list