[commit: ghc] master: reify associated types when reifying typeclasses (5c11523)
git at git.haskell.org
git at git.haskell.org
Wed Sep 23 18:19:22 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/5c115236fe795aa01f0c10106f1b1c959486a739/ghc
>---------------------------------------------------------------
commit 5c115236fe795aa01f0c10106f1b1c959486a739
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date: Wed Sep 23 13:19:58 2015 -0500
reify associated types when reifying typeclasses
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")
Reviewed By: goldfire
Differential Revision: https://phabricator.haskell.org/D1254
GHC Trac Issues: #10891
>---------------------------------------------------------------
5c115236fe795aa01f0c10106f1b1c959486a739
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..a07d80b 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)
+ 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