I am trying to implement my own functor instances and quickcheck them, and have run into issues on typeclasses which are not instances of Eq, namely (->) and IO. My attempts result in a No instance for (Eq ...) error.
In the (->) case I had run into a similar error with Show, i.e. No instance for (Show ...), and was able to fix that by adding a Show (a -> b) instance as suggested in an answer here. It would seem that I might be able to solve also the lack of Eq instances by adding them similarly. However, this question on function equality notes that that in Haskell creating an instance of Eq (a -> b) is equivalent to the halting problem and therefore impossible.
I'm not sure whether creating an instance of Eq IO a is possible. In the IO case I also run into a No instance for (Arbitrary ...) error.
Is there some way to quickcheck the functor properties of the function type (->)? Is there some way to do the same for the IO type?
My code is as follows.
import Prelude hiding (Functor, fmap)
import Test.QuickCheck
import Test.QuickCheck.Function
class Functor f where
fmap :: (a -> b) -> f a -> f b
instance Functor IO where
fmap h f = f >>= (pure . h)
instance Functor ((->) e) where
fmap = (.)
data T a = T
prop_functorid :: (Functor f, Eq (f a)) => T (f a) -> f a -> Bool
prop_functorid T x = fmap id x == x
prop_functorcompose :: (Functor f, Eq (f c)) => T (f a) -> T b -> T c -> f a -> Fun a b -> Fun b c -> Bool
prop_functorcompose T T T x (apply -> g) (apply -> h) =
fmap (h . g) x == (fmap h . fmap g) x
instance Show (a -> b) where
show a= "function"
prop_function :: IO ()
prop_function = do
quickCheck $ prop_functorid (T :: T (String -> String))
quickCheck $ prop_functorcompose (T :: T (String -> String)) (T :: T String) (T :: T String)
prop_io :: IO ()
prop_io = do
quickCheck $ prop_functorid (T :: T (IO String))
quickCheck $ prop_functorcompose (T :: T (IO String)) (T :: T String) (T :: T String)
main = do
prop_function
prop_io
We can have a polymorphic function f :: a -> b implemented for different pairs of a and b. How can we make
twice :: (a -> b) -> a -> c
twice f x = f (f x)
type check? i.e. how can I write a function which applies a polymorphic function twice?
With Rank2Types we can get a bit closer but not quite there:
{-# LANGUAGE Rank2Types #-}
twice1 :: (forall a. a -> (m a)) -> b -> (m (m b))
twice1 f = f . f
twice2 :: (forall a. m a -> a) -> m (m b) -> b
twice2 f = f . f
so then some polymorphic functions can be applied twice:
\> twice1 (:[]) 1
[[1]]
\> twice2 head [[1]]
1
Can we go further?
The question was asked over Haskell cafe 10 years ago but wasn't quite answered (with type classes it becomes a lot of boilerplate).
{-# LANGUAGE TypeFamilies, RankNTypes, UnicodeSyntax #-}
type family Fundep a :: *
type instance Fundep Bool = Int
type instance Fundep Int = String
...
twice :: ∀ a . (∀ c . c -> Fundep c) -> a -> Fundep (Fundep a)
twice f = f . f
Now, that won't be much use actually because you can't define a (meaningful) polymorphic function that works with any c. One possibility is to toss in a class constraint, like
class Showy a where
type Fundep a :: *
showish :: a -> Fundep a
instance Showy Bool where
type Fundep Bool = Int
showish = fromEnum
instance Showy Int where
type Fundep Int = String
showish = show
twice :: ∀ a b . (Showy a, b ~ Fundep a, Showy b) =>
(∀ c . Showy c => c -> Fundep c) -> a -> Fundep b
twice f = f . f
main = print $ twice showish False
You can't make twice generic enough even in a dependently typed setting, but it's possible with intersection types:
twice :: (a -> b /\ b -> c) -> a -> c
twice f x = f (f x)
Now whenever f :: a -> b and f :: b -> c typecheck, twice will typecheck too.
There is also a beautiful spell in Benjamin Pierce's thesis (I changed the syntax slightly):
self : (A /\ A -> B) -> B
self f = f f
So self-application is typeable with intersection types as well.
Given a simple "language":
data Expr a where
ConstE :: a -> Expr a
FMapE :: (b -> a) -> Expr b -> Expr a
instance Functor Expr where
fmap = FMapE
interpret :: Expr a -> a
interpret (ConstE a) = a
interpret (FMapE f a) = f (interpret a)
From that I would like to extract a call graph, eg:
foo = fmap show . fmap (*2) $ ConstE 1
Should result in the graph Node 1 -> Node (*2) -> Node show. Ideally I'd like to store this in a Data.Graph.
What I've come up to this point is that it should be possible to use System.Mem.StableNames to identify individual nodes and store them in a HashMap (StableName (Expr a)) (Expr a).
toHashMap :: Expr a -> HashMap (StableName (Expr a)) (Expr a)
toHashMap n#ConstE = do
sn <- makeStableName n
return $ HashMap.singleton sn n
The problem is, that there seems to be no way to get through the FMapE nodes:
toHashMap n#(FMapE _ a) = do
snN <- makeStableName n
snA <- makeStableName a
-- recurse
hmA <- toHashMap a
-- combine
return $ HashMap.singleton snN n `HashMap.union` hmA
GHC will complain along the lines of this:
Couldn't match type ‘t’ with ‘b’
because type variable ‘b’ would escape its scope
This (rigid, skolem) type variable is bound by
a pattern with constructor
FMapE :: forall a b. (b -> a) -> Expr b -> Expr a,
in an equation for ‘toHashMap’
I can see that this won't match ... but I have no clue on how to make this work.
Edit
This probably boils down to writing a children function:
children :: Event a -> [Event a]
children (ConstE) = []
children (FMapE _ a) = [a] -- doesn't match ...
For the same reason I can't uniplate on this ...
You can get a postorder traversal, which is a tolopogical sort for a tree, of a type of kind * -> * from the Uniplate1 class I've described previously.
{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Monad.Identity
class Uniplate1 f where
uniplate1 :: Applicative m => f a -> (forall b. f b -> m (f b)) -> m (f a)
descend1 :: (forall b. f b -> f b) -> f a -> f a
descend1 f x = runIdentity $ descendM1 (pure . f) x
descendM1 :: Applicative m => (forall b. f b -> m (f b)) -> f a -> m (f a)
descendM1 f a = uniplate1 a f
transform1 :: Uniplate1 f => (forall b. f b -> f b) -> f a -> f a
transform1 f = f . descend1 (transform1 f)
transform1 is a generic postorder tranformation. A generic postorder Monadic traversal of a Uniplate1 is
transformM1 :: (Uniplate1 f, Applicative m, Monad m) =>
(forall b. f b -> m (f b)) ->
f a -> m (f a)
transformM1 f = (>>= f) . descendM1 (transformM1 f)
We can write a Uniplate1 instance for Expr:
instance Uniplate1 Expr where
uniplate1 e p = case e of
FMapE f a -> FMapE f <$> p a
e -> pure e
We'll make a simple dump function for demonstration purposes and bypass to restore the data after a monadic effect.
dump :: Expr b -> IO ()
dump (ConstE _) = putStrLn "ConstE"
dump (FMapE _ _) = putStrLn "FMapE"
bypass :: Monad m => (a -> m ()) -> a -> m a
bypass f x = f x >> return x
We can traverse your example in topological order
> transformM1 (bypass dump) (fmap show . fmap (*2) $ ConstE 1)
ConstE
FMapE
FMapE
It's well known that one way of implementing Haskell typeclasses is via 'typeclass dictionaries'. (This is of course the implementation in ghc, though I make the obligatory remark that Other Implementations are Possible.) To fix ideas, I'll briefly describe how this works. A class declaration like
class (MyClass t) where
test1 :: t -> t -> t
test2 :: t -> String
test3 :: t
can be mechanically transformed into the definition of a datatype like:
data MyClass_ t = MyClass_ {
test1_ :: t -> t -> t,
test2_ :: t -> String,
test3_ :: t,
}
Then we can mechanically transform each instance declaration into an object of that type; for instance:
instance (MyClass Int) where
test1 = (+)
test2 = show
test3 = 3
turns into
instance_MyClass_Int :: MyClass_ Int
instance_MyClass_Int = MyClass_ (+) show 3
and similarly a function which has a typeclass constraint can be turned into a function that takes an extra argument; for instance:
my_function :: (MyClass t) => t -> String
my_function val = test2 . test1 test3
turns into
my_function_ :: MyClass_ t -> t -> String
my_function_ dict val = (test2_ dict) . (test1_ dict) (test3_ dict)
The point is that as long as the compiler knows how to fill in these hidden arguments (which is not totally trivial) then you can translate code that uses classes and instances into code that uses only more basic features of the language.
With that background, here's my question. I have a module M which defines a bunch of classes and functions with class constraints. M is 'opaque'; I can see what it exports (the equivalent of the .hi file) and I can import from it but I can't see its source code. I want to construct a new module N which basically exports the same things but with the transformation above applied. So for instance if M exported
class (Foo t) where
example1 :: t -> t -> t
example2 :: t -- note names and type signatures visible here
-- because they form part of the interface...
instance (Foo String) -- details of implementation invisible
instance (Foo Bool) -- details of implementation invisible
my_fn :: (Foo t) => t -> t -- exported polymorphic fn with class constraint
-- details of implementation invisible
N would start like
module N where
import M
data Foo_ t = Foo_ {example1_ :: t-> t -> t, example2_ :: t}
instance_Foo_String :: Foo_ String
instance_Foo_String = Foo_ example1 example2
instance_Foo_Bool :: Foo_ Bool
instance_Foo_Bool = Foo_ example1 example2
my_fn_ :: Foo_ t -> t -> t
my_fn_ = ???
And my question is what on earth I can put in place of the ???. In other words, what can I write to extract the 'explicit typeclass' version of the function my_fn from the original? It seems rather tricky, and it's infuriating because we all know that 'under the hood' the module M is basically already exporting something like the my_fn_ which I want to create. (Or at least, it is on GHC.)
For the record, I thought I would explain the 'hacky' solution to this which I already know of. I'll basically illustrate it using a series of examples. So let's imagine we're trying to reify the classes, instances and functions in the following (which consists mostly of pretty standard typeclasses, generally simplified somewhat for the exposition):
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Src where
import Data.List (intercalate)
class SimpleShow a where
sshow :: a -> String
class SimpleMonoid a where
mempty :: a
mappend :: a -> a -> a
class SimpleFunctor f where
sfmap :: (a -> b) -> f a -> f b
instance SimpleShow Int where
sshow = show
instance SimpleMonoid [a] where
mempty = []
mappend = (++)
instance SimpleMonoid ([a], [b]) where
mempty = ([], [])
mappend (a1, b1) (a2, b2) = (a1 ++ a2, b1 ++ b2)
instance SimpleFunctor [] where
sfmap = map
There's meant to be some generality in these examples: we have
'a' in positive position in the class member
'a' in negative position in the class member
an instance requiring flexible instances
a higher-kinded type
We leave multi-parameter type families as an exercise! Note that I do believe that what I'm presenting is a completely general, syntactic procedure; I just think it's easier to illustrate with examples than by describing the transformation formally. Anyway, let's suppose we've got the following functions to process:
show_2lists :: (SimpleShow a) => [a] -> [a] -> String
show_2lists as1 as2 = "[" ++ intercalate ", " (map sshow as1) ++ "]/["
++ intercalate ", " (map sshow as2) ++ "]"
mconcat :: (SimpleMonoid a) => [a] -> a
mconcat = foldr mappend mempty
example :: (SimpleMonoid (x, y)) => [(x, y)] -> (x, y)
example = foldr mappend mempty
lift_all :: (SimpleFunctor f) => [a -> b] -> [f a -> f b]
lift_all = map sfmap
Then the actual reification looks like:
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Main where
import Unsafe.Coerce
import Src
data Proxy k = Proxy
class Reifies s a | s -> a where
reflect :: proxy s -> a
newtype Magic a r = Magic (forall (s :: *). Reifies s a => Proxy s -> r)
reify :: forall a r. a -> (forall (s :: *). Reifies s a => Proxy s -> r) -> r
reify a k = unsafeCoerce (Magic k :: Magic a r) (const a) Proxy
{-# INLINE reify #-}
data SimpleShow_ a = SimpleShow_ {sshow_ :: a -> String}
data SimpleMonoid_ a = SimpleMonoid_ {mempty_ :: a,
mappend_ :: a -> a -> a}
data SimpleFunctor_ f = SimpleFunctor_ {
sfmap_ :: forall a b. (a -> b) -> (f a -> f b)
}
instance_SimpleShow_Int :: SimpleShow_ Int
instance_SimpleShow_Int = SimpleShow_ sshow
instance_SimpleMonoid_lista :: SimpleMonoid_ [a]
instance_SimpleMonoid_lista = SimpleMonoid_ mempty mappend
instance_SimpleMonoid_listpair :: SimpleMonoid_ ([a], [b])
instance_SimpleMonoid_listpair = SimpleMonoid_ mempty mappend
instance_SimpleFunctor_list :: SimpleFunctor_ []
instance_SimpleFunctor_list = SimpleFunctor_ sfmap
---------------------------------------------------------------------
--code to reify show_2lists :: (SimpleShow a) => [a] -> [a] -> String
-- for each type variable that occurs in the constraints, we must
-- create a newtype. Here there is only one tpye variable ('a') so we
-- create one newtype.
newtype Wrap_a a s = Wrap_a { extract_a :: a }
-- for each constraint, we must create an instance of the
-- corresponding typeclass where the instance variables have been
-- replaced by the newtypes we just made, as follows.
instance Reifies s (SimpleShow_ a) => SimpleShow (Wrap_a a s) where
--sshow :: (Wrap_ a s) -> String
sshow = unsafeCoerce sshow__
where sshow__ :: a -> String
sshow__ = sshow_ $ reflect (undefined :: [] s)
-- now we can reify the main function
show_2lists_ :: forall a. SimpleShow_ a -> [a] -> [a] -> String
show_2lists_ dict = let
magic :: forall s. ([Wrap_a a s] -> [Wrap_a a s] -> String)
-> Proxy s -> ([a] -> [a] -> String)
magic v _ arg1 arg2 = let
w_arg1 :: [Wrap_a a s]
w_arg1 = unsafeCoerce (arg1 :: [a])
w_arg2 :: [Wrap_a a s]
w_arg2 = unsafeCoerce (arg2 :: [a])
w_ans :: String
w_ans = v w_arg1 w_arg2
ans :: String
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic show_2lists)
---------------------------------------------------------------------
--code to reify mconcat :: (SimpleMonoid a) => [a] -> a
-- Here the newtypes begin with Wrap1 to avoid name collisions with
-- the ones above
newtype Wrap1_a a s = Wrap1_a { extract1_a :: a }
instance Reifies s (SimpleMonoid_ a) => SimpleMonoid (Wrap1_a a s) where
--mappend :: (Wrap1_a a s) -> (Wrap1_a a s) -> (Wrap1_a a s)
mappend = unsafeCoerce mappend__
where mappend__ :: a -> a -> a
mappend__ = (mappend_ $ reflect (undefined :: [] s))
--mempty :: (Wrap1_a a s)
mempty = unsafeCoerce mempty__
where mempty__ :: a
mempty__ = (mempty_ $ reflect (undefined :: [] s))
mconcat_ :: forall a. SimpleMonoid_ a -> [a] -> a
mconcat_ dict = let
magic :: forall s. ([Wrap1_a a s] -> (Wrap1_a a s)) -> Proxy s -> ([a] -> a)
magic v _ arg1 = let
w_arg1 :: [Wrap1_a a s]
w_arg1 = unsafeCoerce (arg1 :: [a])
w_ans :: Wrap1_a a s
w_ans = v w_arg1
ans :: a
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic mconcat)
---------------------------------------------------------------------
--code to reify example :: (SimpleMonoid (x, y)) => [(x, y)] -> (x, y)
newtype Wrap2_x x s = Wrap2_x { extract2_x :: x }
newtype Wrap2_y y s = Wrap2_y { extract2_y :: y }
instance Reifies s (SimpleMonoid_ (x, y))
=> SimpleMonoid (Wrap2_x x s, Wrap2_y y s) where
--mappend :: (Wrap2_x x s, Wrap2_y y s) -> (Wrap2_x x s, Wrap2_y y s)
-- -> (Wrap2_x x s, Wrap2_y y s)
mappend = unsafeCoerce mappend__
where mappend__ :: (x, y) -> (x, y) -> (x, y)
mappend__ = (mappend_ $ reflect (undefined :: [] s))
--mempty :: (Wrap2_x x s, Wrap2_y y s)
mempty = unsafeCoerce mempty__
where mempty__ :: (x, y)
mempty__ = (mempty_ $ reflect (undefined :: [] s))
example_ :: forall x y. SimpleMonoid_ (x, y) -> [(x, y)] -> (x, y)
example_ dict = let
magic :: forall s. ([(Wrap2_x x s, Wrap2_y y s)] -> (Wrap2_x x s, Wrap2_y y s))
-> Proxy s -> ([(x, y)] -> (x, y))
magic v _ arg1 = let
w_arg1 :: [(Wrap2_x x s, Wrap2_y y s)]
w_arg1 = unsafeCoerce (arg1 :: [(x, y)])
w_ans :: (Wrap2_x x s, Wrap2_y y s)
w_ans = v w_arg1
ans :: a
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic mconcat)
---------------------------------------------------------------------
--code to reify lift_all :: (SimpleFunctor f) => [a -> b] -> [f a -> f b]
newtype Wrap_f f s d = Wrap_f { extract_fd :: f d}
instance Reifies s (SimpleFunctor_ f) => SimpleFunctor (Wrap_f f s) where
--sfmap :: (a -> b) -> (Wrap_f f s a -> Wrap_f f s b)
sfmap = unsafeCoerce sfmap__
where sfmap__ :: (a -> b) -> (f a -> f b)
sfmap__ = sfmap_ $ reflect (undefined :: [] s)
lift_all_ :: forall a b f. SimpleFunctor_ f -> [a -> b] -> [f a -> f b]
lift_all_ dict = let
magic :: forall s. ([a -> b] -> [Wrap_f f s a -> Wrap_f f s b])
-> Proxy s -> ([a -> b] -> [f a -> f b])
magic v _ arg1 = let
w_arg1 :: [a -> b]
w_arg1 = unsafeCoerce (arg1 :: [a -> b])
w_ans :: [Wrap_f f s a -> Wrap_f f s b]
w_ans = v w_arg1
ans :: [f a -> f b]
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic lift_all)
main :: IO ()
main = do
print (show_2lists_ instance_SimpleShow_Int [3, 4] [6, 9])
print (mconcat_ instance_SimpleMonoid_lista [[1, 2], [3], [4, 5]])
print (example_ instance_SimpleMonoid_listpair
[([1, 2], ["a", "b"]), ([4], ["q"])])
let fns' :: [[Int] -> [Int]]
fns' = lift_all_ instance_SimpleFunctor_list [\ x -> x+1, \x -> x - 1]
print (map ($ [5, 7]) fns')
{- output:
"[3, 4]/[6, 9]"
[1,2,3,4,5]
([1,2,4],["a","b","q"])
[[6,8],[4,6]]
-}
Note that we use a lot of unsafeCoerce, but always relating two types that differ only in the presence of a newtype. Since the run time representations are identical, this is ok.
What you seem to be asking for is known as "local instances". This would mean that you could write something like:
my_fn_ :: forall t. Foo_ t -> t -> t
my_fn_ fooDict = let instance fooDict :: Foo t
in my_fn
Local instances are a natural extension of type classes. They were even standard in the formalism of Wadler and Blott's paper "How to make ad hoc polymorphism less ad hoc". However, they are problematic because they break a property known as principal types. Additionally, they may also break assumptions that there is only ever a single instance of a certain constraint for a specific type (like e.g. Data.Map's assumption about Ord instances). The first problem could be solved by requiring additional type annotations in a local instance and the latter is related to the controversial "orphan instances", which cause a similar problem.
Another relevant paper is Kiselyov and Shan's "Functional pearl: implicit configurations", which contains a variety of type system tricks to simulate local type instances although it doesn't really apply to your situation (pre-existing type class), IIRC.
This isn't a solution in general, but only for some special cases.
There is a hacky way to do this for class methods of a class C t that have the type parameter t appearing in a negative position in their type. e.g., example1 :: Foo t => t -> t -> t is ok, but not example2 :: Foo t => t.
The trick is to create a wrapper data type Wrapper t which comprises the explicit dictionary methods on t paired with a t value, and which has a Foo instance that exploits the appropriate wrapped dictionary methods, e.g.
data Wrapper x = Wrap {example1__ :: (x -> x -> x), val :: x}
instance Foo (Wrapper x) where
example1 (Wrap example1__ x) (Wrap _ y) = Wrap example1__ (example1__ x y)
my_fn_ :: Foo_ t -> t -> t
my_fn_ (Foo_ example1_ example2_) x = val $ my_fn (Wrap example1_ x)
Something tells me this is probably not the solution you are looking for though- it is not general purpose. In the example here, we cannot do anything with example2 because it has no negative occurrence of t with which to "sneak" functions inside. For your example, this means that my_fn in module M can use only example1.
In Type-Safe Observable Sharing in Haskell Andy Gill shows how to recover sharing that existed on the Haskell level, in a DSL. His solution is implemented in the data-reify package. Can this approach be modified to work with GADTs? For example, given this GADT:
data Ast e where
IntLit :: Int -> Ast Int
Add :: Ast Int -> Ast Int -> Ast Int
BoolLit :: Bool -> Ast Bool
IfThenElse :: Ast Bool -> Ast e -> Ast e -> Ast e
I'd like to recover sharing by transforming the above AST to
type Name = Unique
data Ast2 e where
IntLit2 :: Int -> Ast2 Int
Add2 :: Ast2 Int -> Ast2 Int -> Ast2 Int
BoolLit2 :: Bool -> Ast2 Bool
IfThenElse2 :: Ast2 Bool -> Ast2 e -> Ast2 e -> Ast2 e
Var :: Name -> Ast2 e
by the way of a function
recoverSharing :: Ast -> (Map Name, Ast2 e1, Ast2 e2)
(I'm not sure about the type of recoverSharing.)
Note that I don't care about introducing new bindings via a let construct, but only in recovering the sharing that existed on the Haskell level. That's why I have recoverSharing return a Map.
If it can't be done as reusable package, can it at least be done for specific GADT?
Interesting puzzle! It turns out you can use data-reify with GADTs. What you need is a wrapper that hides the type in an existential. The type can later be retrieved by pattern matching on the Type data type.
data Type a where
Bool :: Type Bool
Int :: Type Int
data WrappedAst s where
Wrap :: Type e -> Ast2 e s -> WrappedAst s
instance MuRef (Ast e) where
type DeRef (Ast e) = WrappedAst
mapDeRef f e = Wrap (getType e) <$> mapDeRef' f e
where
mapDeRef' :: Applicative f => (forall b. (MuRef b, WrappedAst ~ DeRef b) => b -> f u) -> Ast e -> f (Ast2 e u)
mapDeRef' f (IntLit i) = pure $ IntLit2 i
mapDeRef' f (Add a b) = Add2 <$> (Var Int <$> f a) <*> (Var Int <$> f b)
mapDeRef' f (BoolLit b) = pure $ BoolLit2 b
mapDeRef' f (IfThenElse b t e) = IfThenElse2 <$> (Var Bool <$> f b) <*> (Var (getType t) <$> f t) <*> (Var (getType e) <$> f e)
getVar :: Map Name (WrappedAst Name) -> Type e -> Name -> Maybe (Ast2 e Name)
getVar m t n = case m ! n of Wrap t' e -> (\Refl -> e) <$> typeEq t t'
Here's the whole code: https://gist.github.com/3590197
Edit: I like the use of Typeable in the other answer. So I did a version of my code with Typeable too: https://gist.github.com/3593585. The code is significantly shorter. Type e -> is replaced by Typeable e =>, which also has a downside: we no longer know that the possible types are limited to Int and Bool, which means there has to be a Typeable e constraint in IfThenElse.
I will try show that this can be done for specific GADTs, using your GADT as an example.
I will use the Data.Reify package. This requires me to define a new data structure in which the recusive positions are replaced by a parameter.
data AstNode s where
IntLitN :: Int -> AstNode s
AddN :: s -> s -> AstNode s
BoolLitN :: Bool -> AstNode s
IfThenElseN :: TypeRep -> s -> s -> s -> AstNode s
Note that I remove a lot of type information that was available in the original GADT. For the first three constructors it is clear what the associated type was (Int, Int and Bool). For the last one I will remember the type using TypeRep (available in Data.Typeable). The instance for MuRef, required by the reify package, is shown below.
instance Typeable e => MuRef (Ast e) where
type DeRef (Ast e) = AstNode
mapDeRef f (IntLit a) = pure $ IntLitN a
mapDeRef f (Add a b) = AddN <$> f a <*> f b
mapDeRef f (BoolLit a) = pure $ BoolLitN a
mapDeRef f (IfThenElse a b c :: Ast e) =
IfThenElseN (typeOf (undefined::e)) <$> f a <*> f b <*> f c
Now we can use reifyGraph to recover sharing. However, a lot of type information was lost. Lets try to recover it. I altered your definition of Ast2 slightly:
data Ast2 e where
IntLit2 :: Int -> Ast2 Int
Add2 :: Unique -> Unique -> Ast2 Int
BoolLit2 :: Bool -> Ast2 Bool
IfThenElse2 :: Unique -> Unique -> Unique -> Ast2 e
The graph from the reify package looks like this (where e = AstNode):
data Graph e = Graph [(Unique, e Unique)] Unique
Lets make a new graph data structure where we can store Ast2 Int and Ast2 Bool separately (thus, where the type information has been recovered):
data Graph2 = Graph2 [(Unique, Ast2 Int)] [(Unique, Ast2 Bool)] Unique
deriving Show
Now we only need to find a function from Graph AstNode (the result of reifyGraph) to Graph2:
recoverTypes :: Graph AstNode -> Graph2
recoverTypes (Graph xs x) = Graph2 (catMaybes $ map (f toAst2Int) xs)
(catMaybes $ map (f toAst2Bool) xs) x where
f g (u,an) = do a2 <- g an
return (u,a2)
toAst2Int (IntLitN a) = Just $ IntLit2 a
toAst2Int (AddN a b) = Just $ Add2 a b
toAst2Int (IfThenElseN t a b c) | t == typeOf (undefined :: Int)
= Just $ IfThenElse2 a b c
toAst2Int _ = Nothing
toAst2Bool (BoolLitN a) = Just $ BoolLit2 a
toAst2Bool (IfThenElseN t a b c) | t == typeOf (undefined :: Bool)
= Just $ IfThenElse2 a b c
toAst2Bool _ = Nothing
Lets do an example:
expr = Add (IntLit 42) expr
test = do
graph <- reifyGraph expr
print graph
print $ recoverTypes graph
Prints:
let [(1,AddN 2 1),(2,IntLitN 42)] in 1
Graph2 [(1,Add2 2 1),(2,IntLit2 42)] [] 1
The first line shows us that reifyGraph has correctly recovered sharing. The second line shows us that only Ast2 Int types have been found (which is also correct).
This method is easily adaptable for other specific GADTs, but I don't see how it could be made entirely generic.
The complete code can be found at http://pastebin.com/FwQNMDbs .