diff --git a/lgtk.cabal b/lgtk.cabal
--- a/lgtk.cabal
+++ b/lgtk.cabal
@@ -1,5 +1,5 @@
 name:               lgtk
-version:            0.5.4.1
+version:            0.6
 category:           GUI
 synopsis:           lens-based API for Gtk
 description:
@@ -31,9 +31,8 @@
                   , fsnotify
 
                   , transformers
-                  , transformers-base
                   , mtl
-                  , monad-control
+                  , operational
 
                   , gtk
 
@@ -54,10 +53,6 @@
                     LGtk.Demos.Tri
                     LGtk.Demos.IntListEditor
                     LGtk.Demos.TEditor
-
---                    X
---                    OT2
---                    Demo
   other-modules:
                     Data.Lens.Common
 
@@ -66,9 +61,6 @@
                     Control.Monad.ExtRef
                     Control.Monad.ExtRef.Pure
                     Control.Monad.ExtRef.Test
-
-                    Control.Monad.Register
-                    Control.Monad.Register.Basic
 
                     Control.Monad.EffRef
 
diff --git a/src/Control/Monad/EffRef.hs b/src/Control/Monad/EffRef.hs
--- a/src/Control/Monad/EffRef.hs
+++ b/src/Control/Monad/EffRef.hs
@@ -3,34 +3,39 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ConstraintKinds #-}
-module Control.Monad.EffRef
-    ( EffRef (..)
-    , SafeIO (..)
-    , EffIORef (..)
-    , asyncWrite
-    , putStrLn_
-    , forkIOs
-    ) where
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Control.Monad.EffRef where
 
+import Control.Applicative
 import Control.Concurrent
 import Control.Exception (evaluate)
 import Control.Monad
-import Control.Monad.Base
-import Control.Monad.Trans.Control
+import Control.Monad.RWS
+import Control.Monad.Writer
+
+import Control.Monad.State
 import Control.Monad.Trans
 import Control.Monad.Trans.Identity
 import System.Directory
 import System.FSNotify
 import Filesystem.Path hiding (FilePath)
 import Filesystem.Path.CurrentOS hiding (FilePath)
+import Control.Monad.Operational
 
 import Control.Monad.Restricted
-import Control.Monad.Register
 import Control.Monad.ExtRef
+import Control.Monad.ExtRef.Pure
 
 -- | Monad for dynamic actions
 class ExtRef m => EffRef m where
 
+    type CallbackM m :: * -> *
+
+    type EffectM m :: * -> *
+
     liftEffectM' :: Morph (EffectM m) m
 
     {- |
@@ -65,24 +70,90 @@
     -}
     onChange :: Eq a => Bool -> ReadRef m a -> (a -> m (m ())) -> m ()
 
-    toReceive :: Eq a => (a -> WriteRef m ()) -> ((a -> EffectM m ()) -> EffectM m (Command -> EffectM m ())) -> m (Command -> EffectM m ())
+    toReceive :: Eq a => (a -> WriteRef m ()) -> (Command -> EffectM m ()) -> m (a -> CallbackM m ())
 
-    rEffect  :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()
+data Command = Kill | Block | Unblock deriving (Eq, Ord, Show)
 
--- | This instance is used in the implementation, the end users do not need it.
-instance (ExtRef m, MonadRegister m, ExtRef (EffectM m), Ref m ~ Ref (EffectM m)) => EffRef (IdentityT m) where
+rEffect  :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()
+rEffect init r f = onChange init r $ return . liftEffectM' . f
 
-    liftEffectM' = liftEffectM
 
-    onChange init = toSend_ init . liftReadRef
+type SyntEffRef n m x = Program (EffRefI n m x)
+data EffRefI n m x a where
+    SyntLiftEffect :: m a -> EffRefI n m x a
+    SyntLiftExtRef :: SyntExtRef x a -> EffRefI n m x a
+    SyntOnChange :: Eq a => Bool -> SyntRefReader x a -> (a -> SyntEffRef n m x (SyntEffRef n m x ())) -> EffRefI n m x ()
+    SyntReceive  :: Eq a => (a -> SyntRefState x ()) -> (Command -> m ()) -> EffRefI n m x (a -> n ())
 
-    toReceive fm = toReceive_ (liftWriteRef . fm)
+instance ExtRef (SyntEffRef n m x) where
+    type Ref (SyntEffRef n m x) = SyntRef x
+    liftWriteRef w = singleton $ SyntLiftExtRef $ liftWriteRef w
+    extRef r l a = singleton $ SyntLiftExtRef $ extRef r l a
+    newRef a = singleton $ SyntLiftExtRef $ newRef a
 
-    rEffect init r f = onChange init r $ return . liftEffectM' . f
+liftEffectM = singleton . SyntLiftEffect
 
+instance EffRef (SyntEffRef n m x) where
+    type EffectM (SyntEffRef n m x) = m
+    type CallbackM (SyntEffRef n m x) = n
+    liftEffectM' = singleton . SyntLiftEffect
+    onChange b r f = singleton $ SyntOnChange b r f
+    toReceive f g = singleton $ SyntReceive f g
+
+
+type CO m = WriterT (MonadMonoid m, Command -> MonadMonoid m) m
+
+evalRegister' :: (NewRef m) => (StateT LSt m () -> m ()) -> SyntEffRef m (StateT LSt m) (Lens_ LSt) a -> CO (StateT LSt m) a
+evalRegister' ff = eval . view
+  where
+    eval (Return x) = return x
+    eval (SyntLiftEffect m :>>= k) = lift m >>= evalRegister' ff . k
+    eval (SyntLiftExtRef m :>>= k) = lift (runExtRef m) >>= evalRegister' ff . k
+    eval (SyntReceive f g :>>= k) = tell (t2 g) >> evalRegister' ff (k $ ff . runExtRef . liftWriteRef . f)
+    eval (SyntOnChange b r f :>>= k) = toSend__ b (runExtRef $ liftReadRef r) (liftM (evalRegister' ff) . evalRegister' ff . f) >>= evalRegister' ff . k
+
+newRef'' x = liftM (\r -> MorphD $ \m -> StateT $ \s -> runMorphD r $ mapStateT (\k -> runStateT k s >>= \((x, w), s) -> return ((x, s), w)) m) $ newRef' x
+
+--toSend__ :: (Eq b, NewRef m) => Bool -> m b -> (b -> Register' m (Register' m ())) -> Register' m ()
+toSend__ init rb fb = do
+        b <- lift rb
+        v <- case init of
+            False -> return $ Left b
+            True -> lift $ do
+                (c, (s1, ureg1)) <- runWriterT (fb b)
+                (s2, ureg2) <- execWriterT c
+                runMonadMonoid $ s1 `mappend` s2
+                return $ Right [(b, (c, s1, s2, ureg1, ureg2))]
+        memoref <- lift $ lift $ newRef'' v
+                            -- memo table, first item is the newest
+        tell $ t1 $ do
+            b <- rb
+            join $ runMorphD memoref $ StateT $ \memo -> case memo of
+                Left b' | b' == b -> return (return (), memo)
+                Right ((b', (_, s1, s2, _, _)): _) | b' == b ->
+                    return (runMonadMonoid $ s1 `mappend` s2, memo)
+                _ -> do
+                    case memo of
+                        Right ((_, (_, _, _, ureg1, ureg2)): _) ->
+                            runMonadMonoid $ ureg1 Block `mappend` ureg2 Kill
+                        _ -> return ()
+                    (c, (s1, ureg1)) <- case filter ((== b) . fst) $ either (const []) id memo of
+                        ((_, (c, s1, _, ureg1, _)): _) -> do
+                            runMonadMonoid $ ureg1 Unblock
+                            return (c, (s1, ureg1))
+                        _ -> runWriterT (fb b)
+                    (s2, ureg2) <- execWriterT c
+                    let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo
+                    return (runMonadMonoid $ s1 `mappend` s2, memo')
+
+t1 m = (MonadMonoid m, mempty)
+t2 m = (mempty, MonadMonoid . m)
+
+
 -- | Type class for IO actions.
 class (EffRef m, SafeIO m, SafeIO (ReadRef m)) => EffIORef m where
 
+
     {- |
     @(asyncWrite t f a)@ has the effect of doing @(f a)@ after waiting @t@ milliseconds.
 
@@ -92,7 +163,6 @@
     Although @(asyncWrite 0)@ is safe, code using it has a bad small.
     -}
     asyncWrite_ :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()
-    asyncWrite' :: Int -> WriteRef m () -> m ()
 
     {- |
     @(fileRef path)@ returns a reference which holds the actual contents
@@ -110,8 +180,6 @@
     -}
     fileRef    :: FilePath -> m (Ref m (Maybe String))
 
-    -- | Write a string to the standard output device.
-    putStr_    :: String -> m ()
 
     {- | Read a line from the standard input device.
     @(getLine_ f)@ returns immediately. When the line @s@ is read,
@@ -119,7 +187,8 @@
     -}
     getLine_   :: (String -> WriteRef m ()) -> m ()
 
-    registerIO :: Eq a => (a -> WriteRef m ()) -> ((a -> IO ()) -> IO (Command -> IO ())) -> m ()
+    -- | Write a string to the standard output device.
+    putStr_    :: EffIORef m => String -> m ()
 
 -- | @putStrLn_@ === @putStr_ . (++ "\n")@
 putStrLn_ :: EffIORef m => String -> m ()
@@ -128,22 +197,20 @@
 asyncWrite :: EffIORef m => Int -> (a -> WriteRef m ()) -> a -> m ()
 asyncWrite t f a = asyncWrite' t $ f a
 
--- | This instance is used in the implementation, the end users do not need it.
-instance (ExtRef m, MonadRegister m, ExtRef (EffectM m), Ref m ~ Ref (EffectM m), MonadBaseControl IO (EffectM m), SafeIO (ReadRef m), SafeIO m) => EffIORef (IdentityT m) where
+asyncWrite' :: EffIORef m => Int -> WriteRef m () -> m ()
+asyncWrite' t r = asyncWrite_ t (const r) ()
 
-    registerIO r fm = do
-        _ <- toReceive r $ \x -> unliftIO $ \u -> liftM (fmap liftBase) $ fm $ void . u . x
-        return ()
+type SyntEffIORef m x = SyntEffRef m (StateT LSt m) x
 
-    asyncWrite_ t r a
-        = registerIO r $ \re -> forkIOs [ threadDelay t, re a ]
-    asyncWrite' t r = asyncWrite_ t (const r) ()
+instance SafeIO (SyntRefReader x) where
+instance SafeIO (SyntEffIORef m x) where
 
-    putStr_ = liftIO' . putStr
+instance EffIORef (SyntEffIORef IO x) where
 
-    getLine_ w = registerIO w $ \re -> do
-        _ <- forkIO $ getLine >>= re
-        return $ const $ return ()  -- TODO
+    asyncWrite_ t r a = do
+        (u, f) <- liftIO' forkIOs'
+        x <- toReceive r $ liftIO . u
+        liftIO' $ f [ threadDelay t, x a ]
 
     fileRef f = do
         ms <- liftIO' r
@@ -172,8 +239,12 @@
                 watchDir man (directory cf') filt act
 
         liftIO' startm
-        registerIO (writeRef ref) $ \re -> forkForever $ takeMVar v >> r >>= re
-        rEffect False (readRef ref) $ \x -> liftBase $ do
+
+        (u, ff) <- liftIO' forkIOs'
+        re <- toReceive (writeRef ref) $ liftIO . u
+        liftIO' $ ff $ repeat $ takeMVar v >> r >>= re
+
+        rEffect False (readRef ref) $ \x -> liftIO $ do
             join $ takeMVar vman
             _ <- tryTakeMVar v
             putStrLn "  write"
@@ -192,27 +263,36 @@
 
         w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)
 
+    getLine_ w = do
+        (u, f) <- liftIO' forkIOs'
+        x <- toReceive w $ liftIO . u
+        liftIO' $ f [ getLine >>= x ]   -- TODO
+    putStr_ s = liftIO' $ putStr s
 
---liftIO' :: EffIORef_ m => IO a -> m a
-liftIO' m = liftEffectM $ liftBase m
+liftIO__ :: Monad m => m a -> SyntEffIORef m (Lens_ LSt) a
+liftIO__ m = singleton $ SyntLiftEffect $ lift m
 
-forkForever :: IO () -> IO (Command -> IO ())
-forkForever = forkIOs . repeat
+--liftIO' :: EffIORef m => IO a -> m a
+liftIO' m = liftEffectM $ liftIO m
 
-forkIOs :: [IO ()] -> IO (Command -> IO ())
-forkIOs ios = do
+
+--forkIOs' :: IO (Command -> IO (), [IO ()] -> IO ())
+forkIOs' = do
     x <- newMVar ()
-    let g [] = return ()
-        g (i:is) = do
-            () <- takeMVar x
-            putMVar x ()
-            i
-            g is
+    s <- newEmptyMVar
+    let g = do
+            readMVar x
+            is <- takeMVar s
+            case is of
+                [] -> return ()
+                (i:is) -> do
+                    putMVar s is
+                    i
+                    g
         f i Kill = killThread i
         f _ Block = takeMVar x
         f _ Unblock = putMVar x ()
 
-    liftM f $ forkIO $ g ios
-
-
+    i <- forkIO g
+    return (f i, putMVar s)
 
diff --git a/src/Control/Monad/ExtRef.hs b/src/Control/Monad/ExtRef.hs
--- a/src/Control/Monad/ExtRef.hs
+++ b/src/Control/Monad/ExtRef.hs
@@ -2,74 +2,67 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ExistentialQuantification #-}
-module Control.Monad.ExtRef
-    ( module Data.Lens.Common
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Control.Monad.ExtRef where
 
-    -- * Restricted monads
-    , HasReadPart (..)
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+--import Control.Monad.RWS
+--import Control.Monad.Trans.Identity
+--import Control.Monad.Operational
+import Data.Lens.Common
 
-    -- * Reference class
-    , Reference (..)
-    , ReadRefMonad
+-- | @m@ has a submonad @(RefStateReader m)@ which is isomorphic to 'Reader'.
+class (Monad m, Monad (RefStateReader m)) => MonadRefState m where
 
-    -- * Ref construction class
-    , ExtRef (..)
-    , ReadRef
-    , WriteRef
+    {- | Law: @(RefStateReader m)@  ===  @('Reader' x)@ for some @x@.
 
-    -- * Derived constructs
-    , modRef
-    , liftReadRef
-    , readRef'
-    , undoTr
-    , memoRead
-    , memoWrite
+    Alternative laws which ensures this isomorphism (@r :: (RefStateReader m a)@ is arbitrary):
 
-    -- * References with equation
-    , EqReference (..)
-    , EqRef
-    , eqRef
-    , newEqRef
-    , toRef
+     *  @(r >> return ())@ === @return ()@
 
-    -- * Auxiliary definitions
-    , Morph
-    , MorphD (..)
---    , MonadIO' (..)
-    ) where
+     *  @liftM2 (,) r r@ === @liftM (\a -> (a, a)) r@
 
-import Control.Monad
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Control.Monad.RWS
-import Control.Monad.Trans.Identity
-import Data.Maybe
-import Data.Lens.Common
+    See also <http://stackoverflow.com/questions/16123588/what-is-this-special-functor-structure-called>
+    -}
+    type RefStateReader m :: * -> *
 
-import Control.Monad.Restricted
+    -- | @(RefStateReader m)@ is a submonad of @m@
+    liftRefStateReader :: RefStateReader m a -> m a
 
+-- | @RefStateReader (StateT s m) = Reader s@ 
+instance Monad m => MonadRefState (StateT s m) where
+    type RefStateReader (StateT s m) = Reader s
+    liftRefStateReader = gets . runReader
+
+
 {- |
 A reference @(r a)@ is isomorphic to @('Lens' s a)@ for some fixed state @s@.
 
 @r@  ===  @Lens s@
 -}
-class (HasReadPart (RefMonad r)) => Reference r where
+class (MonadRefState (RefState r)) => Reference r where
 
     {- | @Refmonad r@  ===  @State s@
 
-    Property derived from the 'HasReadPart' instance:
+    Property derived from the 'MonadRefState' instance:
 
-    @ReadRefMonad r@ = @ReadPart (Refmonad r)@  ===  @Reader s@
+    @RefReader r@ = @RefStateReader (Refmonad r)@  ===  @Reader s@
     -}
-    type RefMonad r :: * -> *
+    type RefState r :: * -> *
 
     {- | @readRef@ === @reader . getL@
 
-    Properties derived from the 'HasReadPart' instance:
+    Properties derived from the 'MonadRefState' instance:
 
     @(readRef r >> return ())@ === @return ()@
     -}
-    readRef  :: r a -> ReadRefMonad r a
+    readRef  :: r a -> RefReader r a
 
     {- | @writeRef r@ === @modify . setL r@
 
@@ -81,7 +74,7 @@
 
      *  @(writeRef r a >> writeRef r a')@ === @writeRef r a'@
     -}
-    writeRef :: r a -> a -> RefMonad r ()
+    writeRef :: r a -> a -> RefState r ()
 
     {- | Apply a lens on a reference.
 
@@ -95,20 +88,21 @@
 
     @joinRef@ === @Lens . join . (runLens .) . runReader@
     -}
-    joinRef :: ReadRefMonad r (r a) -> r a
+    joinRef :: RefReader r (r a) -> r a
 
     -- | @unitRef@ === @lens (const ()) (const id)@
     unitRef :: r ()
 
-type ReadRefMonad m = ReadPart (RefMonad m)
+type RefReader m = RefStateReader (RefState m)
 
 infixr 8 `lensMap`
 
--- | @modRef r f@ === @liftReadPart (readRef r) >>= writeRef r . f@
-modRef :: Reference r => r a -> (a -> a) -> RefMonad r ()
-r `modRef` f = liftReadPart (readRef r) >>= writeRef r . f
 
+-- | @modRef r f@ === @liftRefStateReader (readRef r) >>= writeRef r . f@
+modRef :: Reference r => r a -> (a -> a) -> RefState r ()
+r `modRef` f = liftRefStateReader (readRef r) >>= writeRef r . f
 
+
 {- | Monad for reference creation. Reference creation is not a method
 of the 'Reference' type class to make possible to
 create the same type of references in multiple monads.
@@ -122,7 +116,7 @@
     type Ref m :: * -> *
 
     -- | @'WriteRef' m@ is a submonad of @m@.
-    liftWriteRef :: Morph (WriteRef m) m
+    liftWriteRef :: WriteRef m a -> m a
 
     {- | Reference creation by extending the state of an existing reference.
 
@@ -151,17 +145,17 @@
     newRef = extRef unitRef $ lens (const ()) (flip $ const id)
 
 
-type WriteRef m = RefMonad (Ref m)
+type WriteRef m = RefState (Ref m)
 
-type ReadRef m = ReadRefMonad (Ref m)
+type ReadRef m = RefReader (Ref m)
 
 {- | @ReadRef@ lifted to the reference creation class.
 
 Note that we do not lift @WriteRef@ to the reference creation class, which a crucial restriction
 in the LGtk interface; this is a feature.
 -}
-liftReadRef :: ExtRef m => Morph (ReadRef m) m
-liftReadRef = liftWriteRef . liftReadPart
+liftReadRef :: ExtRef m => ReadRef m a -> m a
+liftReadRef = liftWriteRef . liftRefStateReader
 
 {- | @readRef@ lifted to the reference creation class.
 
@@ -212,35 +206,8 @@
     liftWriteRef = lift . liftWriteRef
 
     extRef x y a = lift $ extRef x y a
-{-
-instance (ExtRef m) => ExtRef (ReaderT s m) where
 
-    type Ref (ReaderT s m) = Ref m
 
-    liftWriteRef = lift . liftWriteRef
-
-    extRef r k a = lift $ extRef r k a
--}
-
--- | This instance is used in the implementation, end users do not need it.
-instance (ExtRef m) => ExtRef (IdentityT m) where
-
-    type Ref (IdentityT m) = Ref m
-
-    liftWriteRef = lift . liftWriteRef
-
-    extRef r k a = lift $ extRef r k a
-
--- | This instance is used in the implementation, end users do not need it.
-instance (ExtRef m, Monoid w) => ExtRef (RWST r w s m) where
-
-    type Ref (RWST r w s m) = Ref m
-
-    liftWriteRef = lift . liftWriteRef
-
-    extRef r k a = lift $ extRef r k a
-
-
 -- | Undo-redo state transformation.
 undoTr
     :: ExtRef m =>
@@ -281,20 +248,20 @@
     hasEffect
         :: r a
         -> (a -> a)
-        -> ReadRefMonad r Bool
+        -> RefReader r Bool
 
 
 data EqRef_ r a = forall b . Eq b => EqRef_ (r b) (Lens' b a)
 
 {- | References with inherent equivalence.
 
-@EqRef r a@ === @ReadRefMonad r (exist b . Eq b => (Lens' b a, r b))@
+@EqRef r a@ === @RefReader r (exist b . Eq b => (Lens' b a, r b))@
 
 As a reference, @(m :: EqRef r a)@ behaves as
 
 @joinRef $ liftM (uncurry lensMap) m@
 -}
-newtype EqRef r a = EqRef { runEqRef :: ReadRefMonad r (EqRef_ r a) }
+newtype EqRef r a = EqRef { runEqRef :: RefReader r (EqRef_ r a) }
 
 {- | @EqRef@ construction.
 -}
@@ -317,7 +284,7 @@
 
 instance Reference r => Reference (EqRef r) where
 
-    type (RefMonad (EqRef r)) = RefMonad r
+    type (RefState (EqRef r)) = RefState r
 
     readRef = readRef . toRef
 
@@ -328,5 +295,4 @@
     joinRef = EqRef . join . liftM runEqRef
 
     unitRef = eqRef unitRef
-
 
diff --git a/src/Control/Monad/ExtRef/Pure.hs b/src/Control/Monad/ExtRef/Pure.hs
--- a/src/Control/Monad/ExtRef/Pure.hs
+++ b/src/Control/Monad/ExtRef/Pure.hs
@@ -5,77 +5,110 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
 {- |
 Pure reference implementation for the @ExtRef@ interface.
 
 The implementation uses @unsafeCoerce@ internally, but its effect cannot escape.
 -}
-module Control.Monad.ExtRef.Pure
-    ( runExtRef
-    , runExtRef_
-    ) where
+module Control.Monad.ExtRef.Pure where
 
-import Control.Monad.Base
-import Control.Monad.Trans.Control
+--import Control.Monad.Base
+--import Control.Monad.Trans.Control
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Monad.Identity
-import Control.Category
+import Control.Monad.Operational
 import Control.Arrow ((***))
-import Data.Sequence
+import Data.Sequence hiding (singleton)
 import Data.Lens.Common
 import Data.Foldable (toList)
-import Prelude hiding ((.), id, splitAt, length)
+import Prelude hiding (splitAt, length)
 
 import Unsafe.Coerce
-import System.IO.Unsafe
 
-import Control.Monad.Restricted
 import Control.Monad.ExtRef
 
-newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}
+----------------- synthetic data types and instances
 
-instance Reference (Lens_ a) where
+type SyntRefReader x = Program (RefReaderI x)
+data RefReaderI x a where
+    SyntReadRef :: SyntRef x a -> RefReaderI x a
 
-    type RefMonad (Lens_ a) = State a
+type SyntRefState x = Program (RefStateI x)
+data RefStateI x a where
+    SyntLiftRefReader :: SyntRefReader x a -> RefStateI x a
+    SyntWriteRef :: SyntRef x a -> a -> RefStateI x ()
 
-    readRef (Lens_ r) = reader $ getL r
+instance MonadRefState (SyntRefState x) where
+    type RefStateReader (SyntRefState x) = SyntRefReader x
+    liftRefStateReader = singleton . SyntLiftRefReader
 
-    writeRef (Lens_ r) = modify . setL r
+data SyntRef x a where
+    SyntUnitRef :: SyntRef x ()
+    SyntLensMap :: Lens' a b -> SyntRef x a -> SyntRef x b
+    SyntJoinRef :: SyntRefReader x (SyntRef x a) -> SyntRef x a
+    SyntCreatedRef :: x a -> SyntRef x a
 
-    lensMap l (Lens_ r) = Lens_ $ r . l
+instance Reference (SyntRef x) where
+    type RefState (SyntRef x) = SyntRefState x
+    readRef = singleton . SyntReadRef
+    writeRef r = singleton . SyntWriteRef r
+    lensMap = SyntLensMap
+    joinRef = SyntJoinRef
+    unitRef = SyntUnitRef
 
-    unitRef = Lens_ $ lens (const ()) (flip $ const id)
+type SyntExtRef x = Program (ExtRefI x)
+data ExtRefI x a where
+    SyntLiftRefState :: SyntRefState x a -> ExtRefI x a
+    SyntExtRef :: SyntRef x b -> Lens' a b -> a -> ExtRefI x (SyntRef x a)
+--    SyntNewRef :: a -> ExtRefI x (SyntRef x a)
 
-    joinRef m = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader m
+instance ExtRef (SyntExtRef x) where
+    type Ref (SyntExtRef x) = SyntRef x
+    liftWriteRef w = singleton $ SyntLiftRefState w
+    extRef r l = singleton . SyntExtRef r l
+--    newRef = singleton . SyntNewRef
 
 
-type LSt = Seq CC
+----------------------
 
-initLSt :: LSt
-initLSt = empty
+newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}
 
-data CC = forall a . CC (LSt -> a -> a) a
+type LSt = Seq CC
 
-ap_ :: LSt -> CC -> CC
-ap_ x (CC f a) = CC f (f x a)
+data CC = forall a . CC (LSt -> a -> a) a
 
-unsafeData :: CC -> a
-unsafeData (CC _ a) = unsafeCoerce a
+initLSt :: LSt
+initLSt = empty
 
 
-instance Monad m => ExtRef (StateT LSt m) where
+runSyntRefReader :: SyntRefReader (Lens_ x) a -> Reader x a
+runSyntRefReader = interpretWithMonad eval where
+    eval (SyntReadRef r) = reader $ getL $ unLens_ $ runSyntRef r
 
-    type Ref (StateT LSt m) = Lens_ LSt
+runSyntRefState :: SyntRefState (Lens_ x) a -> State x a
+runSyntRefState = interpretWithMonad eval where
+    eval (SyntLiftRefReader r) = liftRefStateReader $ runSyntRefReader r
+    eval (SyntWriteRef r a) = modify $ setL (unLens_ $ runSyntRef r) a
 
-    liftWriteRef = mapStateT (return . runIdentity)
+runSyntRef :: SyntRef (Lens_ x) a -> Lens_ x a
+runSyntRef SyntUnitRef = Lens_ $ lens (const ()) $ const . id
+runSyntRef (SyntLensMap l r) = Lens_ $ (unLens_ $ runSyntRef r) . l
+runSyntRef (SyntJoinRef m) = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader $ liftM runSyntRef $ runSyntRefReader m
+runSyntRef (SyntCreatedRef l) = l
 
-    extRef (Lens_ r1) r2 a0 = state extend  where
+runExtRef :: Monad m => SyntExtRef (Lens_ LSt) a -> StateT LSt m a
+runExtRef = interpretWithMonad eval where
+    eval (SyntLiftRefState w) = mapStateT (return . runIdentity) $ runSyntRefState w
+    eval (SyntExtRef r r2 a0) = state extend
+     where
+        r1 = runSyntRef r
 
-        rk = setL r1 . getL r2
-        kr = setL r2 . getL r1
+        rk = setL (unLens_ r1) . getL r2
+        kr = setL r2 . getL (unLens_ r1)
 
-        extend x0 = (Lens_ $ lens get set, x0 |> CC kr (kr x0 a0))
+        extend x0 = (SyntCreatedRef $ Lens_ $ lens get set, x0 |> CC kr (kr x0 a0))
           where
             limit = (id *** toList) . splitAt (length x0)
 
@@ -84,38 +117,11 @@
             set x a = foldl (\x -> (|>) x . ap_ x) (rk a zs |> CC kr a) ys where
                 (zs, _ : ys) = limit x
 
-
-instance (ExtRef n, Monad m) => ExtRef (Ext n m) where
-    type Ref (Ext n m) = Ref n
-    liftWriteRef = lift' . liftWriteRef
-    extRef r1 r2 = lift' . extRef r1 r2
-
-
--- | Basic running of the @ExtRef@ monad.
-runExtRef :: Monad m => (forall t . (MonadTrans t, ExtRef (t m)) => t m a) -> m a
-runExtRef s = evalStateT s initLSt
-
-
-instance SafeIO (Reader (Seq CC)) where
-
-    getArgs     = runSafeIO getArgs
-    getProgName = runSafeIO getProgName
-    lookupEnv   = runSafeIO . lookupEnv
-
-runSafeIO :: Monad m => IO a -> m a
-runSafeIO = return . unsafePerformIO
-
---instance (MonadBaseControl IO m) => SafeIO m where
-
--- | Advanced running of the @ExtRef@ monad.
-runExtRef_
-    :: forall m a . (MonadBase m m, NewRef m)
-    => (forall t . (MonadTrans t, ExtRef (t m), NewRef (t m), MonadIO (t IO), MonadBaseControl IO (t IO), SafeIO (ReadRef (t IO)), SafeIO (t IO)) => t m a)
-    -> m a
---    -> (Morph (Ext (State LSt) m) m -> Ext (State LSt) m a) -> m a
-runExtRef_ f = newRef' initLSt >>= flip runExt f
-
-
+        ap_ :: LSt -> CC -> CC
+        ap_ x (CC f a) = CC f (f x a)
 
+        unsafeData :: CC -> a
+        unsafeData (CC _ a) = unsafeCoerce a
 
+--    eval (SyntNewRef a) = newRef a
 
diff --git a/src/Control/Monad/ExtRef/Test.hs b/src/Control/Monad/ExtRef/Test.hs
--- a/src/Control/Monad/ExtRef/Test.hs
+++ b/src/Control/Monad/ExtRef/Test.hs
@@ -12,13 +12,14 @@
 --    , testExtIORef
     ) where
 
+import Control.Monad.State
 import Control.Monad.Writer
-import Control.Monad.Identity
 import Control.Category
 import Control.Arrow ((***))
 import Data.Maybe
 import Prelude hiding ((.), id)
 
+import Data.Lens.Common
 import Control.Monad.ExtRef
 import qualified Control.Monad.ExtRef.Pure as Pure
 --import qualified Control.Monad.ExtRef.IORef as IORef
@@ -27,7 +28,7 @@
 
 -- | Consistency tests for the pure implementation of @Ext@, should give an empty list of errors.
 testExtPure :: [String]
-testExtPure = mkTests $ \t -> runIdentity $ Pure.runExtRef $ execWriterT t
+testExtPure = mkTests $ \t -> flip evalState Pure.initLSt $ Pure.runExtRef $ execWriterT t
 
 {-
 -- | Consistency tests for the @IORef@-based implementation of @Ext@, should give an empty list of errors.
@@ -250,7 +251,7 @@
 
     undoTest3 = runTest $ do
         r <- newRef 3
-        (undo, redo) <- liftM (liftReadPart *** liftReadPart) $ undoTr (==) r
+        (undo, redo) <- liftM (liftRefStateReader *** liftRefStateReader) $ undoTr (==) r
         r ==> 3
         redo === False
         undo === False
diff --git a/src/Control/Monad/Register.hs b/src/Control/Monad/Register.hs
deleted file mode 100644
--- a/src/Control/Monad/Register.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Control.Monad.Register
-    ( Command (..)
-    , MonadRegister (..)
-    ) where
-
-import Control.Monad
-import Control.Monad.Trans.Identity
-
-import Control.Monad.Restricted
-
-data Command = Kill | Block | Unblock deriving (Eq, Ord, Show)
-
-class (Monad m, Monad (EffectM m)) => MonadRegister m where
-
-    type EffectM m :: * -> *
-
-    liftEffectM :: Morph (EffectM m) m
-
-    toSend_ :: Eq b => Bool -> EffectM m b -> (b -> m (m ())) -> m ()
-
-    toReceive_ :: Eq a => (a -> EffectM m ()) -> ((a -> EffectM m ()) -> EffectM m (Command -> EffectM m ())) -> m (Command -> EffectM m ())
-
-
-instance MonadRegister m => MonadRegister (IdentityT m) where
-
-    type EffectM (IdentityT m) = EffectM m
-
-    liftEffectM m = IdentityT $ liftEffectM m
-
-    toSend_ init m f = IdentityT $ toSend_ init m $ liftM runIdentityT . runIdentityT . f
-
-    toReceive_ f g = IdentityT $ toReceive_ f g
-
diff --git a/src/Control/Monad/Register/Basic.hs b/src/Control/Monad/Register/Basic.hs
deleted file mode 100644
--- a/src/Control/Monad/Register/Basic.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Control.Monad.Register.Basic
-    ( evalRegister
-    , evalRegisterBasic
-    ) where
-
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.RWS
-import Data.List
-
-import Control.Monad.Restricted
-import Control.Monad.Register
-import Control.Monad.ExtRef
-
-type Register m
-    = RWST (m () -> m ()) (MonadMonoid m, Command -> MonadMonoid m) () m
-
-instance NewRef m => MonadRegister (Register m) where
-
-    type EffectM (Register m) = m
-
-    liftEffectM = lift
-
-    toReceive_ r int = do
-        rr <- ask
-        unreg <- lift $ int $ rr . r
-        tell $ t2 unreg
-        return unreg
-
-    toSend_ init rb fb = do
-        rr <- ask
-        b <- lift rb
-        v <- case init of
-            False -> return $ Left b
-            True -> lift $ do
-                (c, (), (s1, ureg1)) <- runRWST (fb b) rr ()
-                ((), (s2, ureg2)) <- execRWST c rr ()
-                runMonadMonoid $ s1 `mappend` s2
-                return $ Right [(b, (c, s1, s2, ureg1, ureg2))]
-        memoref <- lift $ newRef' v
-                            -- memo table, first item is the newest
-        tell $ t1 $ do
-            b <- rb
-            join $ runMorphD memoref $ StateT $ \memo -> case memo of
-                Left b' | b' == b -> return (return (), memo)
-                Right ((b', (_, s1, s2, _, _)): _) | b' == b ->
-                    return (runMonadMonoid $ s1 `mappend` s2, memo)
-                _ -> do
-                    case memo of
-                        Right ((_, (_, _, _, ureg1, ureg2)): _) ->
-                            runMonadMonoid $ ureg1 Block `mappend` ureg2 Kill
-                        _ -> return ()
-                    (c, (), (s1, ureg1)) <- case filter ((== b) . fst) $ either (const []) id memo of
-                        ((_, (c, s1, _, ureg1, _)): _) -> do
-                            runMonadMonoid $ ureg1 Unblock
-                            return (c, (), (s1, ureg1))
-                        _ -> runRWST (fb b) rr ()
-                    ((), (s2, ureg2)) <- execRWST c rr ()
-                    let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo
-                    return (runMonadMonoid $ s1 `mappend` s2, memo')
-
-t1 m = (MonadMonoid m, mempty)
-t2 m = (mempty, MonadMonoid . m)
-
-evalRegister :: forall k a . (NewRef k, ExtRef k, MonadIO k, SafeIO k)
-    => (forall t . (MonadTrans t, MonadRegister (t k), MonadIO (t k)
-       , ExtRef (t k), Ref (t k) ~ Ref k, EffectM (t k) ~ k, SafeIO (t k)) => t k a)
-    -> (k () -> k ())
-    -> k a
-evalRegister m = evalRegister_ m
-
-evalRegisterBasic
-    :: forall k a . NewRef k
-    => (forall t . (MonadTrans t, MonadRegister (t k)) => t k a)
-    -> (k () -> k ())
-    -> k a
-evalRegisterBasic m = evalRegister_ m
-
-evalRegister_
-    :: NewRef k
-    => (Register k a)
-    -> (k () -> k ())
-    -> k a
-evalRegister_ m ch = do
-    vx <- newRef' $ error "evalRegister"
-    (a, (), reg) <- runRWST m (ch . (>> join (runMorphD vx get))) ()
-    runMorphD vx $ put $ runMonadMonoid $ fst reg
-    return a
-
-
-
diff --git a/src/Control/Monad/Restricted.hs b/src/Control/Monad/Restricted.hs
--- a/src/Control/Monad/Restricted.hs
+++ b/src/Control/Monad/Restricted.hs
@@ -1,35 +1,9 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ConstraintKinds #-}
-module Control.Monad.Restricted
-    ( -- * Auxiliary definitions
-      Morph
-    , MorphD (..)
-    , Ext (..), lift', runExt
-    , HasReadPart (..)
-    , unliftIO, unliftIO'
-    , SafeIO (..)
-    , NewRef (..)
-    , MonadMonoid (..)
-    ) where
+module Control.Monad.Restricted where
 
 import Data.Monoid
---import Control.Monad.Layer hiding (MonadTrans, lift)
---import qualified Control.Monad.Layer as L
-import Control.Applicative
-import Control.Monad.Base
-import Control.Monad.Trans.Control
 import Control.Concurrent
 import Control.Monad.State
-import Control.Monad.Reader
-import Control.Monad.RWS
-import Control.Monad.Trans.Identity
 import qualified System.Environment as Env
 import System.IO.Error (catchIOError, isDoesNotExistError)
 
@@ -44,77 +18,17 @@
 -}
 newtype MorphD m n = MorphD { runMorphD :: Morph m n }
 
--- | @m@ has a submonad @(ReadPart m)@ which is isomorphic to 'Reader'.
-class (Monad m, Monad (ReadPart m)) => HasReadPart m where
-
-    {- | Law: @(ReadPart m)@  ===  @('Reader' x)@ for some @x@.
-
-    Alternative laws which ensures this isomorphism (@r :: (ReadPart m a)@ is arbitrary):
-
-     *  @(r >> return ())@ === @return ()@
-
-     *  @liftM2 (,) r r@ === @liftM (\a -> (a, a)) r@
-
-    See also <http://stackoverflow.com/questions/16123588/what-is-this-special-functor-structure-called>
-    -}
-    type ReadPart m :: * -> *
-
-    -- | @(ReadPart m)@ is a submonad of @m@
-    liftReadPart :: ReadPart m a -> m a
-
--- | @ReadPart (StateT s m) = Reader s@ 
-instance Monad m => HasReadPart (StateT s m) where
-    type ReadPart (StateT s m) = Reader s
-    liftReadPart = gets . runReader
-
-------------------
-
-newtype Ext n m a = Ext { unExt :: ReaderT (MorphD n m) m a }
-    deriving (Monad, MonadIO, Functor, Applicative)
-
-instance MonadTrans (Ext n) where
-    lift = Ext . lift
-
-deriving instance (MonadBase b m) => MonadBase b (Ext n m)
-{-
-instance MonadTransControl (Ext n) where
-    data StT (Ext n) a = StTExt { unStTExt :: a }
---    liftWith     = defaultLiftWith Ext
---    restoreT     = defaultRestoreT   unExt
-
-instance (MonadBaseControl b m) => MonadBaseControl b (Ext n m) where
-    data StM (Ext n m) a = StMExt { unStMExt :: ComposeSt (Ext n) m a }
-    liftBaseWith = defaultLiftBaseWith StMExt
-    restoreM     = defaultRestoreM   unStMExt
--}
-
-instance (MonadBase m m) => MonadBaseControl m (Ext n m) where
-    data StM (Ext n m) a = StMExt { unStMExt :: a }
-    liftBaseWith f = Ext $ do
-        r <- ask
-        lift $ f $ liftM StMExt . flip runReaderT r . unExt
-    restoreM = return . unStMExt
-
-lift' :: Monad m => n a -> Ext n m a
-lift' m = Ext $ do
-    r <- ask
-    lift $ runMorphD r m
-
-unlift :: (MonadBase m m) => ((Ext n m a -> m a) -> m b) -> Ext n m b
-unlift f = liftBaseWith $ \m -> f (liftM (unStMExt) . m)
-
-runExt :: MorphD n m -> Ext n m a -> m a
-runExt v (Ext m) = runReaderT m v
-
-------------------
-
---type MonadIO' m = (MonadIO m, MonadBaseControl IO m)
+-------------------
 
-unliftIO' :: MonadBaseControl n m => ((m () -> n ()) -> m a) -> m a
-unliftIO' f = liftBaseWith (\m -> m $ f $ void . m) >>= restoreM
+class (Monad m) => NewRef m where
+    newRef' :: a -> m (MorphD (StateT a m) m)
 
-unliftIO :: MonadBaseControl n m => ((m () -> n ()) -> n a) -> m a
-unliftIO f = liftBaseWith (\m -> f $ void . m)
+instance NewRef IO where
+    newRef' x = do
+        vx <- liftIO $ newMVar x
+        return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m
+      where
+        swap (a, b) = (b, a)
 
 -------------------
 
@@ -138,42 +52,6 @@
 --    lookupEnv   = Env.lookupEnv -- does not work with Haskell Platform 2013.2.0.0
     lookupEnv v = catchIOError (liftM Just $ Env.getEnv v) $ \e ->
         if isDoesNotExistError e then return Nothing else ioError e
-
--- | This instance is used in the implementation, the end users do not need it.
-instance SafeIO m => SafeIO (Ext n m) where
-
-    getArgs     = lift getArgs
-    getProgName = lift getProgName
-    lookupEnv   = lift . lookupEnv
-
--- | This instance is used in the implementation, the end users do not need it.
-instance SafeIO m => SafeIO (IdentityT m) where
-
-    getArgs     = lift getArgs
-    getProgName = lift getProgName
-    lookupEnv   = lift . lookupEnv
-
--- | This instance is used in the implementation, the end users do not need it.
-instance (SafeIO m, Monoid w) => SafeIO (RWST r w s m) where
-
-    getArgs     = lift getArgs
-    getProgName = lift getProgName
-    lookupEnv   = lift . lookupEnv
-
--------------------
-
-class (Monad m) => NewRef m where
-    newRef' :: a -> m (MorphD (StateT a m) m)
-
-instance NewRef IO where
-    newRef' x = do
-        vx <- liftIO $ newMVar x
-        return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m
-      where
-        swap (a, b) = (b, a)
-
-instance (MonadBase m m, NewRef m) => NewRef (Ext n m) where
-    newRef' = liftM (\m -> MorphD $ \k -> unlift $ runMorphD m . flip mapStateT k) . lift . newRef'
 
 -------------------
 
diff --git a/src/GUI/Gtk/Structures.hs b/src/GUI/Gtk/Structures.hs
--- a/src/GUI/Gtk/Structures.hs
+++ b/src/GUI/Gtk/Structures.hs
@@ -2,55 +2,42 @@
 {-# LANGUAGE RankNTypes #-}
 -- | Lens-based Gtk interface
 module GUI.Gtk.Structures
-    ( Send
-    , Receive
-    , SendReceive
-    , Widget (..)
-    , ListLayout (..)
-    , MouseEvent (..)
-    , ScrollDirection (..)
-    , MousePos (..)
+    ( module GUI.Gtk.Structures
+    , module Graphics.UI.Gtk
     , Color (..)
-    , Modifier (..)
-    , KeyVal
-    , keyName
-    , keyToChar
-    , Dia
-    , Monoid
-    , Semigroup
     ) where
 
---import Graphics.UI.Gtk (Color)
 import Graphics.UI.Gtk.Gdk.GC (Color (Color))
-import Diagrams.Prelude (QDiagram, R2, Monoid, Semigroup)
+import Diagrams.Prelude (QDiagram, R2, Monoid)
 import Diagrams.Backend.Cairo (Cairo)
 import Graphics.UI.Gtk (ScrollDirection (..), KeyVal, Modifier, keyName, keyToChar)
 
-import Control.Monad.Register (Command (..))
+import Control.Monad.EffRef (Command (..))
 
 type Dia a = QDiagram Cairo R2 a
 
 type Send n m a = (a -> n ()) -> m ()
-type Receive n m a = ((a -> n ()) -> n (Command -> n ())) -> m (Command -> n ())
-type SendReceive n m a = (Send n m a, Receive n m a)
+type Receive n m k a = (Command -> n ()) -> m (a -> k ())
+type SendReceive n m k a = (Send n m a, Receive n m k a)
 
+type Widget n m k = m (WidgetCore n m k)
+
 -- | Widget descriptions
-data Widget n m
+data WidgetCore n m k
     = Label (Send n m String)     -- ^ label
     | Button { label_  :: Send n m String
              , sensitive_ :: Send n m Bool
              , color_ :: Send n m Color
-             , action_ :: Receive n m ()
+             , action_ :: Receive n m k ()
              }  -- ^ button
-    | Checkbox (SendReceive n m Bool)         -- ^ checkbox
-    | Combobox [String] (SendReceive n m Int) -- ^ combo box
-    | Entry (SendReceive n m String)          -- ^ entry field
-    | List ListLayout [Widget n m]         -- ^ group interfaces into row or column
-    | Notebook' (Receive n m Int) [(String, Widget n m)]     -- ^ actual tab index, tabs
-    | forall b . Eq b => Cell ((b -> m (m ())) -> m ()) (forall a . (Widget n m -> m a) -> b -> m (m a))
-    | Action (m (Widget n m))              -- ^ do an action before giving the interface
-    | forall a b . (Eq b, Eq a, Monoid a) => Canvas Int Int Double (Receive n m (MouseEvent a)) (Send n m b) (b -> Dia a)
-    | Scale Double Double Double (SendReceive n m Double)
+    | Checkbox (SendReceive n m k Bool)         -- ^ checkbox
+    | Combobox [String] (SendReceive n m k Int) -- ^ combo box
+    | Entry (SendReceive n m k String)          -- ^ entry field
+    | List ListLayout [Widget n m k]         -- ^ group interfaces into row or column
+    | Notebook' (Receive n m k Int) [(String, Widget n m k)]     -- ^ actual tab index, tabs
+    | forall b . Eq b => Cell ((b -> m (m ())) -> m ()) (forall a . (Widget n m k -> m a) -> b -> m (m a))
+    | forall a b . (Eq b, Eq a, Monoid a) => Canvas Int Int Double (Receive n m k (MouseEvent a)) (Send n m b) (b -> Dia a)
+    | Scale Double Double Double (SendReceive n m k Double)
 
 data ListLayout
     = Horizontal
diff --git a/src/GUI/Gtk/Structures/IO.hs b/src/GUI/Gtk/Structures/IO.hs
--- a/src/GUI/Gtk/Structures/IO.hs
+++ b/src/GUI/Gtk/Structures/IO.hs
@@ -4,18 +4,16 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RecursiveDo #-}
 module GUI.Gtk.Structures.IO
     ( runWidget
-    , gtkContext
     ) where
 
 import Control.Category
 import Control.Monad
-import Control.Monad.Trans.Control
+import Control.Monad.State
 import Control.Monad.Writer
-import Control.Monad.IO.Class
 import Control.Concurrent
-import Control.Concurrent.MVar
 import Data.Maybe
 import Data.List hiding (union)
 import Prelude hiding ((.), id)
@@ -24,16 +22,40 @@
 import qualified Graphics.UI.Gtk as Gtk
 --import Graphics.UI.Gtk.Gdk.Events (eventKeyChar)
 
-import Control.Monad.Restricted (Morph)
-import Control.Monad.Register (Command (..))
+import Control.Monad.Restricted
+import Control.Monad.ExtRef
+import Control.Monad.ExtRef.Pure
+import Control.Monad.EffRef
 import GUI.Gtk.Structures
 
-import Diagrams.Prelude hiding (Widget)
+import Diagrams.Prelude
 import Diagrams.Backend.Cairo
 import Diagrams.Backend.Cairo.Internal
 
 -------------------------
 
+{- |
+Run a Gtk widget description.
+
+The widget is shown in a window and the thread enters into the Gtk event cycle.
+It leaves the event cycle when the window is closed.
+-}
+runWidget :: (forall m . EffIORef m => Widget (EffectM m) m (CallbackM m)) -> IO ()
+runWidget desc = gtkContext $ \postGUISync -> mdo
+    postActionsRef <- newRef' $ return ()
+    let addPostAction  = runMorphD postActionsRef . modify . flip (>>)
+        runPostActions = join $ runMorphD postActionsRef $ state $ \m -> (m, return ())
+    actionChannel <- newChan
+    ((widget, (act, _)), s) <- flip runStateT initLSt $ runWriterT $ evalRegister' (writeChan actionChannel) $
+        runWidget_ id addPostAction postGUISync id id liftIO__ liftIO desc
+    runPostActions
+    _ <- forkIO $ void $ flip execStateT s $  forever $ do
+            join $ lift $ readChan actionChannel
+            runMonadMonoid act
+            lift $ runPostActions
+    return widget
+
+
 gtkContext :: (Morph IO IO -> IO SWidget) -> IO ()
 gtkContext m = do
     _ <- unsafeInitGUIForThreadedRTS
@@ -52,26 +74,35 @@
 type SWidget = (IO (), Gtk.Widget)
 
 -- | Run an @IO@ parametrized interface description with Gtk backend
-runWidget
-    :: forall n m . (MonadIO m, MonadIO n)
-    => (n () -> IO ())
+runWidget_
+    :: forall n m k o . (Monad m, Monad o)
+    => (k () -> IO ())
     -> (IO () -> IO ())
     -> Morph IO IO
-    -> Widget n m
-    -> m SWidget
-runWidget nio post' post = toWidget
+    -> Morph m o
+    -> Morph o m
+    -> Morph IO o
+    -> (IO () -> n ())
+    -> Widget n m k
+    -> o SWidget
+runWidget_ nio post' post liftO liftOBack liftIO_ liftION = toWidget
  where
-    liftIO' :: MonadIO k => IO a -> k a
-    liftIO' = liftIO . post
-
---    nio = undefined
+    liftIO' :: IO a -> o a
+    liftIO' = liftIO_ . post
 
-    -- type Receive n m a = ((a -> n ()) -> n (Command -> n ())) -> m (Command -> n ())
-    reg :: Receive n m a -> Receive IO m a
-    reg s f = liftM (nio .) $ s $ liftM (fmap liftIO) . liftIO' . f . (nio .)
+    -- type Receive n m k a = (Command -> n ()) -> m (a -> k ())
+    reg :: Receive n m k a -> ((a -> IO ()) -> IO (Command -> IO ())) -> o (Command -> IO ())
+    reg s f = do
+        rer <- liftIO_ newEmptyMVar
+        u <- liftIO_ $ f $ \x -> do
+            re <- readMVar rer
+            nio $ re x
+        re <- liftO $ s $ liftION . post . u
+        liftIO_ $ putMVar rer re
+        return u
 
-    ger :: (Command -> IO ()) -> Send n m a -> Send IO m a
-    ger hd s f = s $ \a -> liftIO' $ do
+    ger :: (Command -> IO ()) -> Send n m a -> Send IO o a
+    ger hd s f = liftO $ s $ \a -> liftION $ post $ do
         hd Block
         f a
         hd Unblock
@@ -79,26 +110,27 @@
     nhd :: Command -> IO ()
     nhd = const $ return ()
 
-    toWidget :: Widget n m -> m SWidget
-    toWidget i = case i of
+    toWidget :: Widget n m k -> o SWidget
+    toWidget m = liftO m >>= \i -> case i of
 
-        Action m -> m >>= toWidget
+--        Action m -> liftO m >>= toWidget
         Label s -> do
             w <- liftIO' $ labelNew Nothing
             ger nhd s $ labelSetLabel w
             return' w
+
         Canvas w h sc_ me r diaFun -> do
 
-          cur <- liftIO $ newMVar Nothing
-          cur' <- liftIO $ newMVar Nothing
-          v <- liftIO newEmptyMVar
+          cur <- liftIO_ $ newMVar Nothing
+          cur' <- liftIO_ $ newMVar Nothing
+          v <- liftIO_ newEmptyMVar
 
           (canvasDraw, canvas, af, dims) <- liftIO' $ do
             canvas <- drawingAreaNew
             widgetAddEvents canvas [PointerMotionMask]
             af <- aspectFrameNew 0.5 0.5 (Just $ fromIntegral w / fromIntegral h)
-            canvas `onSizeRequest` return (Requisition w h)
-            containerAdd af canvas
+            _ <- canvas `onSizeRequest` return (Requisition w h)
+            _ <- containerAdd af canvas
             let
               dims = do
                 win <- widgetGetDrawWindow canvas
@@ -110,7 +142,7 @@
               tr sc w h dia = translate (r2 (w/2, h/2)) $ dia # scaleY (-1) # scale sc `atop` rect w h # fc white # lw 0
 
               draw dia_ = do
-                swapMVar cur $ Just dia_
+                _ <- swapMVar cur $ Just dia_
                 let dia = freeze $ clearValue dia_
                 (sc, w, h, wi, he) <- dims
                 win <- widgetGetDrawWindow canvas
@@ -127,25 +159,25 @@
                 let p = ((x - w / 2) / sc, (h / 2 - y) / sc)
                 return $ MousePos p $ maybe mempty (`sample` p2 p) d
 
-          hd <- reg me $ \re -> do
-              on' canvas buttonPressEvent $ tryEvent $ do
+          _ <- reg me $ \re -> do
+              _ <- on' canvas buttonPressEvent $ tryEvent $ do
 --                click <- eventClick
                 p <- eventCoordinates >>= liftIO . compCoords
                 liftIO $ re $ Click p
-              on' canvas buttonReleaseEvent $ tryEvent $ do
+              _ <- on' canvas buttonReleaseEvent $ tryEvent $ do
 --                click <- eventClick
                 p <- eventCoordinates >>= liftIO . compCoords
                 liftIO $ re $ Release p
-              on' canvas enterNotifyEvent $ tryEvent $ do
+              _ <- on' canvas enterNotifyEvent $ tryEvent $ do
                 p <- eventCoordinates >>= liftIO . compCoords
                 liftIO $ re $ MouseEnter p
-              on' canvas leaveNotifyEvent $ tryEvent $ do
+              _ <- on' canvas leaveNotifyEvent $ tryEvent $ do
                 p <- eventCoordinates >>= liftIO . compCoords
                 liftIO $ re $ MouseLeave p
-              on' canvas motionNotifyEvent $ tryEvent $ do
+              _ <- on' canvas motionNotifyEvent $ tryEvent $ do
                 p <- eventCoordinates >>= liftIO . compCoords
                 liftIO $ re $ MoveTo p
-              on' canvas scrollEvent $ tryEvent $ do
+              _ <- on' canvas scrollEvent $ tryEvent $ do
                 p <- eventCoordinates >>= liftIO . compCoords
                 dir <- eventScrollDirection
                 liftIO $ re $ ScrollTo dir p
@@ -154,24 +186,24 @@
                 m <- eventModifier
                 c <- eventKeyVal
                 liftIO $ re $ KeyPress m c
-          _ <- liftIO $ on canvas exposeEvent $ tryEvent $ liftIO $ do
+          _ <- liftIO_ $ on canvas exposeEvent $ tryEvent $ liftIO $ do
                 d <- readMVar cur'
                 case d of
                     Just x -> putMVar v x
                     _ -> return ()
 
-          canvasDraw' <- liftIO $ do
+          canvasDraw' <- liftIO_ $ do
             v2 <- newMVar False
-            forkIO $ do
+            _ <- forkIO $ do
               threadDelay 200000
               forever $ do
                 threadDelay 10000
                 dia <- takeMVar v
-                swapMVar cur' $ Just dia
-                swapMVar v2 True
+                _ <- swapMVar cur' $ Just dia
+                _ <- swapMVar v2 True
                 let d = diaFun dia
                 post $ canvasDraw d
-                swapMVar v2 False
+                _ <- swapMVar v2 False
                 return ()
             return $ \dia -> do
                 b <- readMVar v2
@@ -204,13 +236,13 @@
             return' w
         Scale a b c (r, s) -> do
             w <- liftIO' $ hScaleNewWithRange a b c
-            liftIO' $ w `onSizeRequest` return (Requisition 200 40)
+            _ <- liftIO' $ w `onSizeRequest` return (Requisition 200 40)
             hd <- reg s $ \re -> on' w valueChanged $ rangeGetValue w >>= re
             ger hd r $ rangeSetValue w
             return' w
         Combobox ss (r, s) -> do
             w <- liftIO' comboBoxNewText
-            liftIO' $ w `onSizeRequest` return (Requisition 50 30)
+            _ <- liftIO' $ w `onSizeRequest` return (Requisition 50 30)
             liftIO' $ flip mapM_ ss $ comboBoxAppendText w
             hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re
             ger hd r $ comboBoxSetActive w
@@ -234,10 +266,10 @@
             w <- liftIO' $ case b of
                 True -> fmap castToContainer $ hBoxNew False 1
                 False -> fmap castToContainer $ alignmentNew 0 0 1 1
-            sh <- liftIO $ newMVar $ return ()
-            onCh $ \bv -> do
-                mx <- f toWidget bv
-                return $ mx >>= \(x, y) -> liftIO' $ do 
+            sh <- liftIO_ $ newMVar $ return ()
+            liftO $ onCh $ \bv -> do
+                mx <- f (liftOBack . toWidget) bv
+                return $ mx >>= \(x, y) -> liftOBack $ liftIO' $ do 
                     _ <- swapMVar sh x
                     containerForeach w $ if b then widgetHideAll else containerRemove w 
                     post' $ post $ do
diff --git a/src/LGtk.hs b/src/LGtk.hs
--- a/src/LGtk.hs
+++ b/src/LGtk.hs
@@ -3,15 +3,15 @@
 -- | Main LGtk interface.
 module LGtk
     (
-    -- * Monad morphisms
-      Morph
-    , HasReadPart (..)
-
     -- * References
-    -- ** Basic operations
+
+    -- ** Reference modifying monad
+      MonadRefState (..)
+
+    -- ** Reference operations
     , Reference
-    , RefMonad
-    , ReadRefMonad
+    , RefState
+    , RefReader
     , readRef
     , writeRef
     , lensMap
@@ -102,22 +102,15 @@
     ) where
 
 import Data.Maybe
-import Control.Concurrent
+import Data.Monoid
 import Control.Monad
-import Control.Monad.Base
-import Control.Monad.State
-import Control.Monad.Trans.Identity
 import Data.Lens.Common
 
 import Control.Monad.ExtRef
-import Control.Monad.Register
-import Control.Monad.Register.Basic
 import Control.Monad.EffRef
 import GUI.Gtk.Structures hiding (Send, Receive, SendReceive, Widget)
 import qualified GUI.Gtk.Structures as Gtk
 import qualified GUI.Gtk.Structures.IO as Gtk
---import qualified GUI.Gtk.Structures.ThreePenny as TP
-import Control.Monad.ExtRef.Pure
 import Control.Monad.Restricted
 
 
@@ -129,8 +122,10 @@
 @Widget@ should be abstract data type, but it is also safe to keep it as a type synonym because
 the operations of the revealed implementation are hidden.
 -}
-type Widget m = Gtk.Widget (EffectM m) m
+type Widget m = Gtk.Widget (EffectM m) m (CallbackM m)
 
+--type SyntWidget = Widget (SyntEffIORef X)
+
 {- |
 Run a Gtk widget description.
 
@@ -138,56 +133,23 @@
 It leaves the event cycle when the window is closed.
 -}
 runWidget :: (forall m . EffIORef m => Widget m) -> IO ()
-runWidget desc = do
-    postActionsRef <- newRef' $ return ()
-    let addPostAction  = runMorphD postActionsRef . modify . flip (>>)
-        runPostActions = join $ runMorphD postActionsRef $ state $ \m -> (m, return ())
-    actionChannel <- newChan
-    _ <- forkIO $ forever $ do
-        join $ readChan actionChannel
-        runPostActions
-    Gtk.gtkContext $ \postGUISync -> do
-        widget <- runExtRef_ $ unliftIO' $ \unlift ->
-            evalRegister
-                (runIdentityT $ Gtk.runWidget unlift addPostAction postGUISync desc)
-                (liftIO . writeChan actionChannel . void . unlift)
-        runPostActions
-        return widget
-{-
-runWidget' :: (forall m . EffIORef m => Widget m) -> IO ()
-runWidget' desc = do
-
-    postActionsRef <- newRef' $ return ()
-    let addPostAction  = runMorphD postActionsRef . modify . flip (>>)
-        runPostActions = join $ runMorphD postActionsRef $ state $ \m -> (m, return ())
-    actionChannel <- newChan
-    _ <- forkIO $ forever $ do
-        join $ readChan actionChannel
-        runPostActions
+runWidget = Gtk.runWidget
 
-    TP.gtkContext $ \w -> do
-        widget <- runExtRef_ $ unliftIO' $ \unlift ->
-            evalRegister
-                (runIdentityT $ TP.runWidget unlift addPostAction w desc)
-                (liftBase . writeChan actionChannel . void . unlift)
---        runPostActions
-        return widget
--}
 -- | Vertical composition of widgets.
-vcat :: [Widget m] -> Widget m
-vcat = List Vertical
+vcat :: Monad m => [Widget m] -> Widget m
+vcat = return . List Vertical
 
 -- | Horizontal composition of widgets.
-hcat :: [Widget m] -> Widget m
-hcat = List Horizontal
+hcat :: Monad m => [Widget m] -> Widget m
+hcat = return . List Horizontal
 
 -- | Empty widget.
-empty :: Widget m
+empty :: Monad m => Widget m
 empty = hcat []
 
 -- | Dynamic label.
 label :: EffRef m => ReadRef m String -> Widget m
-label = Label . rEffect True
+label = return . Label . rEffect True
 
 -- | Low-level button with changeable background color.
 button__
@@ -197,7 +159,7 @@
     -> ReadRef m Color      -- ^ dynamic background color
     -> WriteRef m ()        -- ^ the action to do when the button is pressed
     -> Widget m
-button__ r x c y = Button (rEffect True r) (rEffect True x) (rEffect True c) (toReceive $ \() -> y)
+button__ r x c y = return $ Button (rEffect True r) (rEffect True x) (rEffect True c) (toReceive $ \() -> y)
 
 -- | Low-level button.
 button_
@@ -206,19 +168,19 @@
     -> ReadRef m Bool       -- ^ the button is active when this returns @True@
     -> WriteRef m ()        -- ^ the action to do when the button is pressed
     -> Widget m
-button_ r x y = Button (rEffect True r) (rEffect True x) (const $ return ()) (toReceive $ \() -> y)
+button_ r x y = return $ Button (rEffect True r) (rEffect True x) (const $ return ()) (toReceive $ \() -> y)
 
 button
     :: EffRef m
     => ReadRef m String     -- ^ dynamic label of the button
     -> ReadRef m (Maybe (WriteRef m ()))     -- ^ when the @Maybe@ value is @Nothing@, the button is inactive
     -> Widget m
-button r fm = button_ r (liftM isJust fm) (liftReadPart fm >>= maybe (return ()) id)
+button r fm = button_ r (liftM isJust fm) (liftRefStateReader fm >>= maybe (return ()) id)
 
 
 
 smartButton
-    :: (EffRef m, EqReference r, RefMonad r ~ RefMonad (Ref m)) 
+    :: (EffRef m, EqReference r, RefState r ~ RefState (Ref m)) 
     => ReadRef m String     -- ^ dynamic label of the button
     -> r a              -- ^ underlying reference
     -> (a -> a)   -- ^ The button is active when this function is not identity on value of the reference. When the button is pressed, the value of the reference is modified with this function.
@@ -228,18 +190,18 @@
 
 -- | Checkbox.
 checkbox :: EffRef m => Ref m Bool -> Widget m
-checkbox r = Checkbox (rEffect True (readRef r), toReceive $ writeRef r)
+checkbox r = return $ Checkbox (rEffect True (readRef r), toReceive $ writeRef r)
 
 -- | Simple combo box.
 combobox :: EffRef m => [String] -> Ref m Int -> Widget m
-combobox ss r = Combobox ss (rEffect True (readRef r), toReceive $ writeRef r)
+combobox ss r = return $ Combobox ss (rEffect True (readRef r), toReceive $ writeRef r)
 
 -- | Text entry.
-entry :: (EffRef m, Reference r, RefMonad r ~ RefMonad (Ref m))  => r String -> Widget m
-entry r = Entry (rEffect True (readRef r), toReceive $ writeRef r)
+entry :: (EffRef m, Reference r, RefState r ~ RefState (Ref m))  => r String -> Widget m
+entry r = return $ Entry (rEffect True (readRef r), toReceive $ writeRef r)
 
 -- | Text entry.
-entryShow :: (EffRef m, Show a, Read a, Reference r, RefMonad r ~ RefMonad (Ref m)) => r a -> Widget m
+entryShow :: (EffRef m, Show a, Read a, Reference r, RefState r ~ RefState (Ref m)) => r a -> Widget m
 entryShow r = entry $ showLens `lensMap` r
 
 {- | Notebook (tabs).
@@ -247,7 +209,7 @@
 The tabs are created lazily.
 -}
 notebook :: EffRef m => [(String, Widget m)] -> Widget m
-notebook xs = Action $ do
+notebook xs = do
     currentPage <- newRef 0
     let f index (title, w) = (,) title $ cell (liftM (== index) $ readRef currentPage) $ \b -> case b of
            False -> hcat []
@@ -259,7 +221,7 @@
 The monadic action for inner widget creation is memoised in the first monad layer.
 -}
 cell_ :: (EffRef m, Eq a) => ReadRef m a -> (forall x . (Widget m -> m x) -> a -> m (m x)) -> Widget m
-cell_ = Cell . onChange True
+cell_ r = return . Cell (onChange True r)
 
 {- | Dynamic cell.
 
@@ -277,12 +239,12 @@
 
 -- | @action@ makes possible to do any 'EffRef' action while creating the widget.
 action :: EffRef m => m (Widget m) -> Widget m
-action = Action
+action = join
 
 canvas :: (EffRef m, Eq b, Eq a, Monoid a) => Int -> Int -> Double -> (MouseEvent a -> WriteRef m ()) -> ReadRef m b -> (b -> Dia a) -> Widget m
-canvas w h sc me r f = Canvas w h sc (toReceive me) (rEffect True r) f
+canvas w h sc me r f = return $ Canvas w h sc (toReceive me) (rEffect True r) f
  -- = cellNoMemo r $ Canvas_ w h sc . f  -- Canvas f $ rEffect True r
 
 hscale :: (EffRef m) => Double -> Double -> Double -> Ref m Double -> Widget m
-hscale a b c r = Scale a b c (rEffect True $ readRef r, toReceive $ writeRef r)
+hscale a b c r = return $ Scale a b c (rEffect True $ readRef r, toReceive $ writeRef r)
 
diff --git a/src/LGtk/Demos/IntListEditor.hs b/src/LGtk/Demos/IntListEditor.hs
--- a/src/LGtk/Demos/IntListEditor.hs
+++ b/src/LGtk/Demos/IntListEditor.hs
@@ -62,7 +62,7 @@
         , button_ (return "Copy") (return True) $ modRef list $ \xs -> take (i+1) xs ++ drop i xs
         ]
 
-    safeList = lens id (const . take maxi) `lensMap` list
+    safeList = lens id (const $ take maxi) `lensMap` list
 
     sel = liftM (filter snd) $ readRef list