Commit 5c115236 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Austin Seipp

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
parent 453cdbfc
......@@ -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.
......
{-# 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