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

5 files changed, 80 insertions, 2 deletions

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 2a21705c77..c8eb9f8850 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 0000000000..d91caf94f6
--- /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 0000000000..874f4f0890
--- /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 503f5331f0..e65558774a 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 f72cc30f81..9d4736c10f 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'])