Ast pattern functor

gistfile1.txt

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE PatternSynonyms      #-}

data TType = Lvalue | Expr

data T :: TType -> (TType -> *) -> * where
    LvalueId :: String -> T Lvalue r
    LvalueAx :: r Lvalue -> r Expr -> T Lvalue r

    ExprInt :: Integer -> T Expr r
    ExprLvalue :: r Lvalue -> T Expr r

deriving instance (Show (r Lvalue), Show (r Expr)) => Show (T x r)

class HFunctor t where
    ffmap :: (forall a . f a -> g a) -> t f -> t g

instance HFunctor (T k) where
    ffmap f (LvalueId s) =  LvalueId s
    ffmap f (LvalueAx l e) = LvalueAx (f l) (f e)
    ffmap f (ExprInt i) = ExprInt i
    ffmap f (ExprLvalue l) = ExprLvalue (f l)

data HCofree (f :: k -> (k -> *) -> *) a (i :: k) = a :< f i (HCofree f a)

pattern HC :: f i (HCofree f ()) -> HCofree f () i
pattern HC x = () :< x

deriving instance {-# OVERLAPPABLE #-} (Show a, Show (f i (HCofree f a))) => Show (HCofree f a i)

instance {-# OVERLAPPING #-} (Show (f i (HCofree f ()))) => Show (HCofree f () i) where
    show (_ :< x) = show x

convert :: HFunctor (T i) => (a -> b) -> HCofree T a i -> HCofree T b i
convert f (x :< y) = f x :< ffmap (convert f) y

strip :: HFunctor (T i) => HCofree T a i -> HCofree T () i
strip = convert $ const ()

example :: HCofree T () 'Lvalue
example = HC (LvalueAx (HC (LvalueId "id")) (HC (ExprInt 0)))

main :: IO ()
main = do
    print example
    print $ convert (const "ann") example
    print $ convert Just example
    print $ strip $ convert (const "ann") example