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

module Data.TrieMap.Regular.Base where

import Data.TrieMap.TrieKey

newtype K0 a r = K0 {unK0 :: a} deriving (Show)
newtype I0 r = I0 {unI0 :: r} deriving (Show)
data U0 r = U0 deriving (Show)
data (f :*: g) r = f r :*: g r deriving (Show)
data (f :+: g) r = L (f r) | R (g r) deriving (Show)
newtype L f r = List [f r] deriving (Show)
newtype Reg r = Reg {unReg :: r} deriving (Show)

newtype Fix f = In {out :: f (Fix f)}

type family PF a :: * -> *

class Regular a where
	from :: a -> PF a a
	to :: PF a a -> a

type instance PF (K0 a r) = K0 a
type instance PF (I0 r) = I0
type instance PF (U0 r) = U0
type instance PF ((f :*: g) r) = PF (f r) :*: PF (g r)
type instance PF ((f :+: g) r) = PF (f r) :+: PF (g r)
type instance PF (Fix f) = f
type instance PF [a] = L (PF a)
type instance PF (L f a) = L (PF (f a))
-- type instance PF Bool = K Bool
-- type instance PF Int = K Int
-- type instance PF Char = K Char
-- type instance PF 

instance Functor (K0 a) where
	fmap _ (K0 a) = K0 a

instance Functor I0 where
	fmap f (I0 a) = I0 (f a)

instance Functor U0 where
	fmap _ U0 = U0

instance Functor f => Functor (L f) where
	fmap f (List xs) = List (map (fmap f) xs)

instance (Functor f, Functor g) => Functor (f :*: g) where
	fmap f (x :*: y) = fmap f x :*: fmap f y

instance (Functor f, Functor g) => Functor (f :+: g) where
	fmap f (L x) = L (fmap f x)
	fmap f (R x) = R (fmap f x)

from' :: (Functor (PF a), Regular a) => Reg a -> PF a (Reg a)
from' (Reg a) = fmap Reg (from a)

to' :: (Functor (PF a), Regular a) => PF a (Reg a) -> Reg a
to' = Reg . to . fmap unReg

infixr 7 :*:
infixr 6 :+: