-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}

module Control.Monatron.Zipper where

import Control.Monatron.MonadT ()
import Control.Monatron.IdT ()
import Control.Monatron.AutoLift 
import Control.Monatron.Operations
import Control.Monatron.Monad ()
-- import Monatron.AutoInstances()

newtype (t1 :> (t2 :: (* -> *) -> * -> *)) m a = L { runL :: t1 (t2 m) a }

runZipper :: (t1 :> t2) m a -> t1 (t2 m) a
runZipper = runL

zipper :: t1 (t2 m) a -> (t1 :> t2) m a 
zipper = L

-- * Relative Navigation

-- | shift focus to left
leftL  :: (t1 :> t2) m a -> t1 (t2 m) a
leftL   = runL

-- | shift focus to right
rightL :: t1 (t2 m) a -> (t1 :> t2) m  a
rightL  =  L 

-- The zipper is an FMonadT and a MonadT

instance (FMonadT t1, FMonadT t2) => FMonadT (t1 :> t2) where
     tmap' d1 d2 g f       = 
       L . tmap' (FunctorD (mtmap d1)) (FunctorD (mtmap d2)) g (tmap' d1 d2 id f) . runL

instance (MonadT t1, MonadT t2) => MonadT (t1 :> t2) where
     lift         = L . lift . lift
     tbind m f    = L $ runL m >>= runL . f
     
-- Instances of the zipper for the various effects
     
instance (Monad m, MonadT t1, MonadT t2, StateM z (t2 m)) => StateM z ((t1 :> t2) m) where
     stateModel = L . liftAlgModel stateModel
     
instance (WriterM z (t2 m), MonadT t1, Monad m, MonadT t2) => WriterM z ((t1 :> t2) m) where
     writerModel  = L . liftAlgModel writerModel

instance (ReaderM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => 
         ReaderM z ((t1 :> t2) m) where     
      readerModel  = L . liftModel readerModel . fmap runL 
      
instance (ExcM z (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => 
         ExcM z ((t1 :> t2) m) where
    throwModel  = L . liftAlgModel throwModel
    handleModel = L . liftModel handleModel . fmap runL 
    
instance (ContM r (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => 
         ContM r ((t1 :> t2) m) where
    contModel = L . liftAlgModel contModel
    
instance (ListM (t2 m), FMonadT t1, FMonadT t2, Functor (t2 m), Monad m) => 
         ListM ((t1 :> t2) m) where
    listModel = L . liftAlgModel listModel
    
-- runtest :: (((),Int),Int)
-- runtest = runState 0 $ runStateT 0 $ runZipper (put 3)

-- Views and masks; could be in a different file
    
data (:><:) m n = View {
  to    :: forall a . m a -> n a,
  from  :: forall a . n a -> m a
}

i :: m :><: m
i = View id id

o :: (Monad m, MonadT t1, MonadT t2) => t1 (t2 m) :><: (t1 :> t2) m
o = View rightL leftL

vlift  :: (FMonadT t, Functor m, Functor n) 
       => (m :><: n) -> (t m :><: t n)
vlift v  = View (tmap (to v)) (tmap (from v))


hcomp :: (n :><: o) -> (m :><: n) -> (m :><: o)
v2 `hcomp` v1  =  View  (to v2 . to v1) (from v1 . from v2)

vcomp  :: (Functor m1, Functor m2, FMonadT t) 
       => (t m2 :><: m3) -> (m1 :><: m2) -> (t m1 :><: m3)
v2 `vcomp` v1  = v2 `hcomp` (vlift v1)

-- program :: StateM Int m => m Int
-- program = put 3 >> return 4

-- t = runState 1 $ runStateT 0 $ runIdT $ runIdT $ view i program

r :: Monad m => StateT s m :><: ReaderT s m
r  = View  {
  to    = \s -> readerT (\e -> liftM fst $ runStateT e s),
  from  = \e -> stateT (\s ->  liftM (\x -> (x,s)) $ runReaderT s e)
}

stateIso  :: Monad m => (s1 -> s2) -> (s2 -> s1) -> StateT s1 m :><: StateT s2 m
stateIso f fm1 = View  {to = iso f fm1, from = iso fm1 f } where 
  iso g h m = stateT $ \s2 -> do  (a, s1) <- runStateT (h s2) m
                                  return (a, g s1)
                                  
getv :: StateM s n => (m :><: n) -> m s
getv var  = from var get 

putv :: StateM s n => (m :><: n) -> s -> m ()
putv var  = from var . put