Commit b4d43b4e authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Ben Gamari

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
parent 988b2baa
......@@ -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.
......
{-# 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''
[| () |])
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
......@@ -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
......
......@@ -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'])
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