module Control.Instances.Morph (GenMorph(..), DB, db, Morph, morph) where
import Control.Instances.ShortestPath
import Control.Monad.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.List
import Data.Maybe
import Data.Proxy
type Morph m1 m2 = GenMorph DB m1 m2
morph :: Morph m1 m2 => m1 a -> m2 a
morph = genMorph db
type GenMorph db m1 m2 = ( CorrectPath m1 m2 (Path db m1 m2)
, GeneratableMorph db (Path db m1 m2)
, Morph' (Path db m1 m2) m1 m2
)
type Path db m1 m2 = TransformPath (PathFromList (ShortestPath (ToMorphRepo db) m1 m2))
genMorph :: forall db m1 m2 a . GenMorph db m1 m2 => db -> m1 a -> m2 a
genMorph db = repr (generateMorph db :: (Path db m1 m2))
class Morph' fl x y where
repr :: fl -> x a -> y a
instance Morph' r y z => Morph' (ConnectMorph x y :+: r) x z where
repr (ConnectMorph m :+: r) = repr r . m
instance (Morph' r m x, Monad m) => Morph' (IdentityMorph m :+: r) Identity x where
repr (IdentityMorph :+: r) = (repr r :: forall a . m a -> x a) . return . runIdentity
instance Morph' (MUMorph m :+: r) m Proxy where
repr (MUMorph :+: _) = const Proxy
instance Morph' NoMorph x x where
repr _ = id
infixr 6 :+:
data a :+: r = a :+: r
data NoMorph = NoMorph
type family ToMorphRepo db where
ToMorphRepo (cm :+: r) = TranslateConn cm ': ToMorphRepo r
ToMorphRepo NoMorph = '[]
type DB = ConnectMorph_2m Maybe MaybeT
:+: ConnectMorph_mt MaybeT
:+: ConnectMorph Maybe []
:+: ConnectMorph_2m [] ListT
:+: ConnectMorph (MaybeT IO) (ListT IO)
:+: NoMorph
db :: DB
db = ConnectMorph_2m (MaybeT . return)
:+: ConnectMorph_mt (MaybeT . liftM Just)
:+: ConnectMorph (maybeToList)
:+: ConnectMorph_2m (ListT . return)
:+: ConnectMorph (ListT . liftM maybeToList . runMaybeT)
:+: NoMorph
class GeneratableMorph db ch where
generateMorph :: db -> ch
instance GeneratableMorph db NoMorph where
generateMorph _ = NoMorph
instance GeneratableMorph db r
=> GeneratableMorph db ((IdentityMorph m) :+: r) where
generateMorph db = IdentityMorph :+: generateMorph db
instance GeneratableMorph db r
=> GeneratableMorph db (MUMorph m :+: r) where
generateMorph db = MUMorph :+: generateMorph db
instance (HasMorph db (ConnectMorph a b), GeneratableMorph db r)
=> GeneratableMorph db (ConnectMorph a b :+: r) where
generateMorph db = getMorph db :+: generateMorph db
class HasMorph r m where
getMorph :: r -> m
instance Monad k => HasMorph (ConnectMorph_2m a b :+: r) (ConnectMorph a (b k)) where
getMorph (ConnectMorph_2m f :+: _) = ConnectMorph f
instance Monad k => HasMorph (ConnectMorph_mt t :+: r) (ConnectMorph k (t k)) where
getMorph (ConnectMorph_mt f :+: _) = ConnectMorph f
instance HasMorph r m => HasMorph (c :+: r) m where
getMorph (_ :+: r) = getMorph r
instance HasMorph (m :+: r) m where
getMorph (c :+: _) = c
class CorrectPath from to path
instance CorrectPath from to (a :+: b)
instance CorrectPath from to NoMorph
data ConnectMorph m1 m2 = ConnectMorph (forall a . m1 a -> m2 a)
data ConnectMorph_2m m1 m2 = ConnectMorph_2m (forall a k . Monad k => m1 a -> m2 k a)
data ConnectMorph_mt mt = ConnectMorph_mt (forall a k . Monad k => k a -> mt k a)
data IdentityMorph (m :: * -> *) = IdentityMorph
data MUMorph m = MUMorph
type family TranslateConn m where
TranslateConn (ConnectMorph m1 m2) = Connect m1 m2
TranslateConn (ConnectMorph_2m m1 m2) = Connect_2m m1 m2
TranslateConn (ConnectMorph_mt mt) = Connect_mt mt
type family TransformPath m where
TransformPath (Connect m1 m2 :+: r) = ConnectMorph m1 m2 :+: TransformPath r
TransformPath (Connect_id m :+: r) = IdentityMorph m :+: TransformPath r
TransformPath (Connect_MU m :+: r) = MUMorph m :+: TransformPath r
TransformPath NoMorph = NoMorph
TransformPath NoPathFound = NoPathFound
type family PathFromList ls where
PathFromList '[] = NoMorph
PathFromList '[ NoPathFound ] = NoPathFound
PathFromList (c ': ls) = c :+: PathFromList ls