Base.hs

{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, ExistentialQuantification, KindSignatures, FlexibleInstances, MultiParamTypeClasses #-}

module Data.TrieMap.MultiRec.Base (module Generics.MultiRec.Base, module Generics.MultiRec.HFix, {-A0(..), X(..), -}Family(..), FamT(..), KeyFam(..), FunctorT (..), breakEither) where

import Data.TrieMap.TrieKey

import Generics.MultiRec
import Generics.MultiRec.Base
import Generics.MultiRec.HFix

import Control.Applicative

-- newtype A f (r :: * -> *) ix = A {unA :: f r ix}
-- newtype A0 (r :: * -> *) ix = A0 {unA0 :: r ix}
-- newtype R (r1 :: * -> *) (r :: * -> *) ix = Rec {unRec :: r1 (r ix)}
-- newtype X (r :: * -> *) ix = X {unX :: ix}
newtype Family (phi :: * -> *) ix = F ix

data KeyFam k = TrieKey k (TrieMap k) => KF
newtype FamT (phi :: * -> *) f ix = FamT (f ix)

instance TrieKey k (TrieMap k) => El KeyFam k where
	proof = KF

-- instance HFunctor phi f => HFunctor phi (A f) where
-- 	hmapA f pf (A x) = A <$> hmapA f pf x

-- instance HFunctor phi A0 where
-- 	hmapA f pf (A0 x) = A0 <$> f pf x

-- instance HEq phi f => HEq phi (A f) where
-- 	heq f pf (A x) (A y) = heq f pf x y

-- instance HEq phi A0 where
-- 	heq f pf (A0 x) (A0 y) = f pf x y

class FunctorT f where
	fmapp :: Functor r => (a -> b) -> f r a -> f r b

instance FunctorT (FamT phi) where
	fmapp f (FamT x) = FamT (fmap f x)

instance Functor (Family phi) where
	fmap f (F x) = F (f x)

instance Functor f => Functor (FamT phi f) where
	fmap = fmapp

instance FunctorT (K k) where
	fmapp = fmap

instance Functor (K k r) where
	fmap f (K a) = K a

instance FunctorT (I ix) where
	fmapp = fmap

instance Functor (I ix r) where
	fmap f (I a) = I a

instance FunctorT U where
	fmapp f U = U 

instance Functor (U r) where
	fmap f U = U

instance (FunctorT f, FunctorT g) => FunctorT (f :*: g) where	
	fmapp f (x :*: y) = fmapp f x :*: fmapp f y

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

instance (FunctorT f, FunctorT g) => FunctorT (f :+: g) where
	fmapp f (L l) = L (fmapp f l)
	fmapp f (R r) = R (fmapp f r)

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

-- instance FunctorT f => FunctorT (A f) where
-- 	fmapp f (A x) = A (fmapp f x)

-- instance FunctorT A0 where
-- 	fmapp f (A0 x) = A0 (fmap f x)

-- instance (FunctorT f, Functor r) => Functor (A f r) where
-- 	fmap = fmapp

-- instance Functor r => Functor (A0 r) where
-- 	fmap = fmapp

-- instance FunctorT X where
-- 	fmapp = fmap

-- instance Functor (X r) where
-- 	fmap f (X x) = X (f x)

instance FunctorT f => Functor (HFix f) where
	fmap f (HIn x) = HIn (fmapp f x)

breakEither :: [((f :+: g) r ix, a)] -> ([(f r ix, a)], [(g r ix, a)])
breakEither = foldr breakEither' ([], []) where
	breakEither' (L k, a) (xs, ys) = ((k, a):xs, ys)
	breakEither' (R k, a) (xs, ys) = (xs, (k, a):ys)