Everywhere.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Everywhere where

import GHC.Generics
import Unsafe.Coerce

class GTypeable f where
    gtypeRef :: f a -> (String, String)

instance Datatype c => GTypeable (M1 i c f) where
    gtypeRef x = (moduleName x, datatypeName x)

class Typeable a where
    typeRef :: a -> (String, String)

    default typeRef :: (Generic a, GTypeable (Rep a)) => a -> (String, String)
    typeRef = gtypeRef . from

class GEverywhere f where
    geverywhere :: (forall b. Typeable b => b -> b) -> f a -> f a

instance GEverywhere U1 where
    geverywhere _ _ = U1

instance (GEverywhere a, GEverywhere b) => GEverywhere (a :*: b) where
     geverywhere f (x :*: y) = geverywhere f x :*: geverywhere f y

instance (GEverywhere a, GEverywhere b) => GEverywhere (a :+: b) where
    geverywhere f (L1 x) = L1 (geverywhere f x)
    geverywhere f (R1 x) = R1 (geverywhere f x)

instance GEverywhere a => GEverywhere (M1 i c a) where
    geverywhere f (M1 x) = M1 (geverywhere f x)

instance (Typeable a) => GEverywhere (K1 i a) where
    geverywhere f (K1 x) = K1 (f x)

class Everywhere a where
    everywhere :: (forall b. Typeable b => b -> b) -> a -> a

    default everywhere :: (Generic a, GEverywhere (Rep a))
                       => (forall b. Typeable b => b -> b) -> a -> a
    everywhere f x = to (geverywhere f (from x))

mkT :: forall a. Typeable a => (a -> a) -> forall b. Typeable b => b -> b
mkT f x  = if typeRef (undefined :: a) == typeRef x then
              unsafeCoerce (f (unsafeCoerce x))
           else x

data Tree a = Leaf a | Node (Tree a) (Tree a)
    deriving (Show, Generic)

instance Typeable Int
instance Typeable Bool
instance Typeable a => Typeable (Tree a)
instance Typeable a => Everywhere (Tree a)

foo :: Typeable a => Tree a -> Tree a
foo = everywhere (mkT ((+ 1) :: Int -> Int))