{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}

module StructView where

data Var a = Var a
data Rec t = Rec t

data Unit    = Unit
data a :*: b = a :*: b
data a :+: b = Inl a | Inr b

class Representable a where
  type Repr a

  toRepr   :: a -> Repr a
  fromRepr :: Repr a -> a

instance Representable [a] where
  type Repr [a] = Unit :+: (Var a :*: Rec [a])

  toRepr (x:xs) = Inr (Var x :*: Rec xs)
  toRepr []     = Inl Unit

  fromRepr (Inr (Var x :*: Rec xs)) = x : xs
  fromRepr (Inl Unit)               = []

class Mappable t a b where
  type Rebind t a b

  mapit :: (a -> b) -> t -> Rebind t a b

instance Mappable Unit a b where
  type Rebind Unit a b = Unit

  mapit f Unit = Unit

instance (Mappable t a b, Mappable u a b) => Mappable (t :*: u) a b where
  type Rebind (t :*: u) a b = Rebind t a b :*: Rebind u a b

  mapit f (t :*: u) = mapit f t :*: mapit f u

instance (Mappable t a b, Mappable u a b) => Mappable (t :+: u) a b where
  type Rebind (t :+: u) a b = Rebind t a b :+: Rebind u a b

  mapit f (Inl t) = Inl (mapit f t)
  mapit f (Inr u) = Inr (mapit f u)

instance Mappable (Var a) a b where
  type Rebind (Var a) a b = Var b

  mapit f (Var a) = Var (f a)


class Fun f where
  mapp :: (a -> b) -> f a -> f b

instance Fun f => Mappable (Rec (f a)) a b where
  type Rebind (Rec (f a)) a b = Rec (f b)

  mapit f (Rec t) = Rec (mapp f t)

generic_map :: (Representable (f a), Representable (f b), 
                Mappable (Repr (f a)) a b, 
                Rebind (Repr (f a)) a b ~ Repr (f b)) 
            => (a -> b) -> f a -> f b
generic_map f x = fromRepr (mapit f (toRepr x))

instance Fun [] where
  mapp = generic_map