diff --git a/lgtk.cabal b/lgtk.cabal
--- a/lgtk.cabal
+++ b/lgtk.cabal
@@ -1,5 +1,5 @@
 name:               lgtk
-version:            0.5.3
+version:            0.5.4
 category:           GUI
 synopsis:           lens-based API for Gtk
 description:
@@ -30,20 +30,37 @@
                   , system-filepath
                   , fsnotify
 
-                  , data-lens
                   , transformers
+                  , transformers-base
                   , mtl
+                  , monad-control
 
                   , gtk
+
+--                  , threepenny-gui == 0.4.1.*
+
+                  , diagrams-lib
+                  , diagrams-cairo
+                  , SVGFonts
+                  , groups
+
+                  , lens
   exposed-modules:
                     LGtk
+
                     LGtk.ADTEditor
 
                     LGtk.Demos.Main
                     LGtk.Demos.Tri
                     LGtk.Demos.IntListEditor
                     LGtk.Demos.TEditor
+
+--                    X
+--                    OT2
+--                    Demo
   other-modules:
+                    Data.Lens.Common
+
                     Control.Monad.Restricted
 
                     Control.Monad.ExtRef
@@ -83,4 +100,5 @@
                     -fno-warn-missing-signatures 
                     -fno-warn-orphans
                     -fno-warn-type-defaults
+
 
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
@@ -2,10 +2,12 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Control.Monad.EffRef
     ( EffRef (..)
     , SafeIO (..)
     , EffIORef (..)
+    , asyncWrite
     , putStrLn_
     , forkIOs
     ) where
@@ -13,13 +15,14 @@
 import Control.Concurrent
 import Control.Exception (evaluate)
 import Control.Monad
+import Control.Monad.Base
+import Control.Monad.Trans.Control
 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 Prelude hiding ((.), id)
 
 import Control.Monad.Restricted
 import Control.Monad.Register
@@ -88,7 +91,8 @@
     the current computation.
     Although @(asyncWrite 0)@ is safe, code using it has a bad small.
     -}
-    asyncWrite :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()
+    asyncWrite_ :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()
+    asyncWrite' :: Int -> WriteRef m () -> m ()
 
     {- |
     @(fileRef path)@ returns a reference which holds the actual contents
@@ -121,17 +125,19 @@
 putStrLn_ :: EffIORef m => String -> m ()
 putStrLn_ = putStr_ . (++ "\n")
 
-
+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), MonadIO' (EffectM m), SafeIO (ReadRef m), SafeIO m) => EffIORef (IdentityT m) where
+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
 
     registerIO r fm = do
-        _ <- toReceive r $ \x -> unliftIO $ \u -> liftM (fmap liftIO) $ liftIO $ fm $ u . x
+        _ <- toReceive r $ \x -> unliftIO $ \u -> liftM (fmap liftBase) $ fm $ void . u . x
         return ()
 
-    asyncWrite t r a
+    asyncWrite_ t r a
         = registerIO r $ \re -> forkIOs [ threadDelay t, re a ]
+    asyncWrite' t r = asyncWrite_ t (const r) ()
 
     putStr_ = liftIO' . putStr
 
@@ -144,7 +150,7 @@
         ref <- newRef ms
         v <- liftIO' newEmptyMVar
         vman <- liftIO' newEmptyMVar
-        cf <- liftIO' $ canonicalizePath f
+        cf <- liftIO' $ canonicalizePath f   -- FIXME: canonicalizePath may fail if the file does not exsist
         let
             cf' = decodeString cf
             g = (== cf')
@@ -155,21 +161,24 @@
             filt (Modified x _) = g x
             filt (Removed x _) = g x
 
-            act (Added _ _) = h
-            act (Modified _ _) = h
-            act (Removed _ _) = h
+            act (Added _ _) = putStrLn "added" >> h
+            act (Modified _ _) = putStrLn "mod" >> h
+            act (Removed _ _) = putStrLn "rem" >> h
 
             startm = do
+                putStrLn " start" 
                 man <- startManager
+                putMVar vman $ putStrLn " stop" >> stopManager man
                 watchDir man (directory cf') filt act
-                putMVar vman $ stopManager man
 
         liftIO' startm
         registerIO (writeRef ref) $ \re -> forkForever $ takeMVar v >> r >>= re
-        rEffect False (readRef ref) $ \x -> liftIO $ do
+        rEffect False (readRef ref) $ \x -> liftBase $ do
             join $ takeMVar vman
             _ <- tryTakeMVar v
+            putStrLn "  write"
             w x
+            threadDelay 10000
             startm
         return ref
      where
@@ -185,7 +194,7 @@
 
 
 --liftIO' :: EffIORef_ m => IO a -> m a
-liftIO' m = liftEffectM $ liftIO m
+liftIO' m = liftEffectM $ liftBase m
 
 forkForever :: IO () -> IO (Command -> IO ())
 forkForever = forkIOs . repeat
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
@@ -35,16 +35,7 @@
     -- * Auxiliary definitions
     , Morph
     , MorphD (..)
-    , MonadIO' (..)
-
-    -- * Auxiliary lens definitions
-    , listLens
-    , maybeLens
-    , showLens
-
-    -- * Re-exported
-    , (.)
-    , id
+--    , MonadIO' (..)
     ) where
 
 import Control.Monad
@@ -52,10 +43,8 @@
 import Control.Monad.Writer
 import Control.Monad.RWS
 import Control.Monad.Trans.Identity
-import Control.Category
 import Data.Maybe
 import Data.Lens.Common
-import Prelude hiding ((.), id)
 
 import Control.Monad.Restricted
 
@@ -98,7 +87,7 @@
 
     @lensMap@ === @(.)@
     -}
-    lensMap :: Lens a b -> r a -> r b
+    lensMap :: Lens' a b -> r a -> r b
 
     {- | @joinRef@ makes possible to define dynamic references, i.e. references which depends on
     values of other references.
@@ -152,14 +141,14 @@
 
      *  @(extRef r k a0 >>= readRef)@ === @(readRef r >>= setL k a0)@
     -}
-    extRef :: Ref m b -> Lens a b -> a -> m (Ref m a)
+    extRef :: Ref m b -> Lens' a b -> a -> m (Ref m a)
 
     {- | @newRef@ extends the state @s@ in an independent way.
 
     @newRef@ === @extRef unitRef (lens (const ()) (const id))@
     -}
     newRef :: a -> m (Ref m a)
-    newRef = extRef unitRef $ lens (const ()) (const id)
+    newRef = extRef unitRef $ lens (const ()) (flip $ const id)
 
 
 type WriteRef m = RefMonad (Ref m)
@@ -261,22 +250,23 @@
            , ReadRef m (Maybe (WriteRef m ()))
            )  -- ^ undo and redo actions
 undoTr eq r = do
-    ku <- extRef r undoLens ([], [])
+    ku <- extRef r (undoLens eq) ([], [])
     let try f = liftM (liftM (writeRef ku) . f) $ readRef ku
     return (try undo, try redo)
   where
-    undoLens = lens get set where
-        get = head . fst
-        set x (x' : xs, ys) | eq x x' = (x: xs, ys)
-        set x (xs, _) = (x : xs, [])
-
     undo (x: xs@(_:_), ys) = Just (xs, x: ys)
     undo _ = Nothing
 
     redo (xs, y: ys) = Just (y: xs, ys)
     redo _ = Nothing
 
+undoLens :: (a -> a -> Bool) -> Lens' ([a],[a]) a
+undoLens eq = lens get set where
+    get = head . fst
+    set (x' : xs, ys) x | eq x x' = (x: xs, ys)
+    set (xs, _) x = (x : xs, [])
 
+
 {- | References with inherent equivalence.
 
 -}
@@ -294,11 +284,11 @@
         -> ReadRefMonad r Bool
 
 
-data EqRef_ r a = forall b . Eq b => EqRef_ (r b) (Lens b a)
+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@ === @ReadRefMonad r (exist b . Eq b => (Lens' b a, r b))@
 
 As a reference, @(m :: EqRef r a)@ behaves as
 
@@ -333,28 +323,10 @@
 
     writeRef = writeRef . toRef
 
-    lensMap l (EqRef m) = EqRef $ m >>= \(EqRef_ r k) -> return $ EqRef_ r $ l . k
+    lensMap l (EqRef m) = EqRef $ m >>= \(EqRef_ r k) -> return $ EqRef_ r $ k . l
 
     joinRef = EqRef . join . liftM runEqRef
 
     unitRef = eqRef unitRef
-
-
-
-
-showLens :: (Show a, Read a) => Lens a String
-showLens = lens show $ \s def -> maybe def fst $ listToMaybe $ reads s
-
-listLens :: Lens (Bool, (a, [a])) [a]
-listLens = lens get set where
-    get (False, _) = []
-    get (True, (l, r)) = l: r
-    set [] (_, x) = (False, x)
-    set (l: r) _ = (True, (l, r))
-
-
-maybeLens :: Lens (Bool, a) (Maybe a)
-maybeLens = lens (\(b,a) -> if b then Just a else Nothing)
-              (\x (_,a) -> maybe (False, a) (\a' -> (True, a')) x)
 
 
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
@@ -3,6 +3,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {- |
 Pure reference implementation for the @ExtRef@ interface.
 
@@ -13,6 +15,8 @@
     , runExtRef_
     ) where
 
+import Control.Monad.Base
+import Control.Monad.Trans.Control
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Monad.Identity
@@ -29,20 +33,21 @@
 import Control.Monad.Restricted
 import Control.Monad.ExtRef
 
+newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}
 
-instance Reference (Lens a) where
+instance Reference (Lens_ a) where
 
-    type RefMonad (Lens a) = State a
+    type RefMonad (Lens_ a) = State a
 
-    readRef = reader . getL
+    readRef (Lens_ r) = reader $ getL r
 
-    writeRef r = modify . setL r
+    writeRef (Lens_ r) = modify . setL r
 
-    lensMap = (.)
+    lensMap l (Lens_ r) = Lens_ $ r . l
 
-    unitRef = lens (const ()) (const id)
+    unitRef = Lens_ $ lens (const ()) (flip $ const id)
 
-    joinRef = Lens . join . (runLens .) . runReader
+    joinRef m = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader m
 
 
 type LSt = Seq CC
@@ -61,22 +66,22 @@
 
 instance Monad m => ExtRef (StateT LSt m) where
 
-    type Ref (StateT LSt m) = Lens LSt
+    type Ref (StateT LSt m) = Lens_ LSt
 
     liftWriteRef = mapStateT (return . runIdentity)
 
-    extRef r1 r2 a0 = state extend  where
+    extRef (Lens_ r1) r2 a0 = state extend  where
 
         rk = setL r1 . getL r2
         kr = setL r2 . getL r1
 
-        extend x0 = (lens get set, x0 |> CC kr (kr x0 a0))
+        extend x0 = (Lens_ $ lens get set, x0 |> CC kr (kr x0 a0))
           where
             limit = (id *** toList) . splitAt (length x0)
 
             get = unsafeData . head . snd . limit
 
-            set a x = foldl (\x -> (|>) x . ap_ x) (rk a zs |> CC kr a) ys where
+            set x a = foldl (\x -> (|>) x . ap_ x) (rk a zs |> CC kr a) ys where
                 (zs, _ : ys) = limit x
 
 
@@ -100,11 +105,12 @@
 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 . NewRef m
-    => (forall t . (MonadTrans t, ExtRef (t m), NewRef (t m), MonadIO' (t IO), SafeIO (ReadRef (t IO)), SafeIO (t IO)) => t m a)
+    :: 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
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
@@ -239,13 +239,13 @@
 
     undoTest = runTest $ do
         r <- newRef 3
-        q <- extRef r (lens head (:)) []
+        q <- extRef r (lens head $ flip (:)) []
         writeRef' r 4
         q ==> [4, 3]
 
     undoTest2 = runTest $ do
         r <- newRef 3
-        q <- extRef r (lens head (:)) []
+        q <- extRef r (lens head $ flip (:)) []
         q ==> [3]
 
     undoTest3 = runTest $ do
diff --git a/src/Control/Monad/Register/Basic.hs b/src/Control/Monad/Register/Basic.hs
--- a/src/Control/Monad/Register/Basic.hs
+++ b/src/Control/Monad/Register/Basic.hs
@@ -11,7 +11,6 @@
 import Control.Monad.State
 import Control.Monad.RWS
 import Data.List
-import Prelude hiding ((.), id)
 
 import Control.Monad.Restricted
 import Control.Monad.Register
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
@@ -4,19 +4,27 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Control.Monad.Restricted
     ( -- * Auxiliary definitions
       Morph
     , MorphD (..)
     , Ext (..), lift', runExt
     , HasReadPart (..)
-    , MonadIO' (..)
+    , unliftIO, unliftIO'
     , SafeIO (..)
     , NewRef (..)
     , MonadMonoid (..)
     ) 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
@@ -52,46 +60,64 @@
     type ReadPart m :: * -> *
 
     -- | @(ReadPart m)@ is a submonad of @m@
-    liftReadPart :: Morph (ReadPart m) 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)
-
-deriving instance MonadIO' (Ext n IO)
+    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 :: Monad m => ((Ext n m a -> m a) -> m b) -> Ext n m b
-unlift f = Ext $ do
-    r <- ask
-    lift $ f $ flip runReaderT r . unExt
+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
 
-class MonadIO m => MonadIO' m where
-    unliftIO :: (Morph m IO -> m b) -> m b
+------------------
 
-instance MonadIO' IO where
-    unliftIO f = f id
+--type MonadIO' m = (MonadIO m, MonadBaseControl IO m)
 
-instance MonadIO' (ReaderT r IO) where
-    unliftIO f = do
-        x <- ask
-        f $ \m -> runReaderT m x
+unliftIO' :: MonadBaseControl n m => ((m () -> n ()) -> m a) -> m a
+unliftIO' f = liftBaseWith (\m -> m $ f $ void . m) >>= restoreM
 
+unliftIO :: MonadBaseControl n m => ((m () -> n ()) -> n a) -> m a
+unliftIO f = liftBaseWith (\m -> f $ void . m)
+
+-------------------
+
 -- | Type class for effectless, synchronous @IO@ actions.
 class Monad m => SafeIO m where
 
@@ -134,9 +160,11 @@
     getProgName = lift getProgName
     lookupEnv   = lift . lookupEnv
 
-class Monad m => NewRef m where
-    newRef' :: forall a . a -> m (MorphD (StateT a m) m)
+-------------------
 
+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
@@ -144,8 +172,10 @@
       where
         swap (a, b) = (b, a)
 
-instance NewRef m => NewRef (Ext n m) where
+instance (MonadBase m m, NewRef m) => NewRef (Ext n m) where
     newRef' = liftM (\m -> MorphD $ \k -> unlift $ runMorphD m . flip mapStateT k) . lift . newRef'
+
+-------------------
 
 newtype MonadMonoid a = MonadMonoid { runMonadMonoid :: a () }
 
diff --git a/src/Data/Lens/Common.hs b/src/Data/Lens/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Lens/Common.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module Data.Lens.Common
+  ( Lens
+  , Lens'
+  -- * Lens construction
+  , lens -- build a lens from a getter and setter
+  -- * Functional API
+  , getL  -- (^.)
+  , setL  -- set
+  , modL  -- over
+  -- * Stock lenses
+  , fstLens
+  , sndLens
+  , showLens
+  , listLens
+  , maybeLens
+  ) where
+
+import Data.Maybe
+import Control.Applicative
+import Control.Monad.Identity
+
+--------- re-define to avoid dependency on lens
+type Lens s t a b = Functor f => (a -> f b) -> s -> f t
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+
+-- | build a lens out of an isomorphism
+iso :: (s -> a) -> (b -> t) -> Lens s t a b
+iso f g = lens f $ flip $ const . g
+
+-- | Gets the getter function from a lens.
+getL :: Lens' a b -> a -> b
+getL l = getConst . l Const
+
+-- | Gets the setter function from a lens.
+setL :: Lens s t a b -> b -> s -> t
+setL l s = runIdentity . l (const $ Identity s)
+
+-- | Gets the modifier function from a lens.
+modL :: Lens s t a b -> (a -> b) -> s -> t
+modL l f = runIdentity . l (Identity . f)
+
+-- * Stock lenses
+fstLens :: Lens (x,b) (y,b) x y
+fstLens = lens fst $ \(a,b) x -> (x,b)
+
+sndLens :: Lens (a,x) (a,y) x y
+sndLens = lens snd $ \(a,b) x -> (a,x)
+
+showLens :: (Show a, Read a) => Lens' a String
+showLens = lens show $ \def s -> maybe def fst $ listToMaybe $ reads s
+
+listLens :: Lens' (Bool, (a, [a])) [a]
+listLens = lens get set where
+    get (False, _) = []
+    get (True, (l, r)) = l: r
+    set (_, x) [] = (False, x)
+    set _ (l: r) = (True, (l, r))
+
+maybeLens :: Lens' (Bool, a) (Maybe a)
+maybeLens = lens (\(b,a) -> if b then Just a else Nothing)
+              (\(_,a) x -> maybe (False, a) (\a' -> (True, a')) x)
+
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
@@ -7,14 +7,29 @@
     , SendReceive
     , Widget (..)
     , ListLayout (..)
+    , MouseEvent (..)
+    , ScrollDirection (..)
+    , MousePos (..)
     , 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.Backend.Cairo (Cairo)
+import Graphics.UI.Gtk (ScrollDirection (..), KeyVal, Modifier, keyName, keyToChar)
 
 import Control.Monad.Register (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)
@@ -34,7 +49,25 @@
     | 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)
 
 data ListLayout
-    = Horizontal | Vertical
+    = Horizontal
+    | Vertical
+        deriving (Eq)
 
+data MouseEvent a
+    = MoveTo (MousePos a)
+    | MouseEnter (MousePos a)
+    | MouseLeave (MousePos a)
+    | Click (MousePos a)
+    | DragTo (MousePos a)
+    | Release (MousePos a)
+    | ScrollTo ScrollDirection (MousePos a)
+    | KeyPress [Modifier] KeyVal
+        deriving (Eq)
+
+data MousePos a
+    = MousePos (Double, Double) a
+        deriving (Eq)
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
@@ -3,6 +3,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module GUI.Gtk.Structures.IO
     ( runWidget
     , gtkContext
@@ -10,18 +11,29 @@
 
 import Control.Category
 import Control.Monad
+import Control.Monad.Trans.Control
 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)
 
-import Graphics.UI.Gtk hiding (Widget)
+import Graphics.UI.Gtk hiding (Widget, Release)
 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 GUI.Gtk.Structures
 
+import Diagrams.Prelude hiding (Widget)
+import Diagrams.Backend.Cairo
+import Diagrams.Backend.Cairo.Internal
+
+-------------------------
+
 gtkContext :: (Morph IO IO -> IO SWidget) -> IO ()
 gtkContext m = do
     _ <- unsafeInitGUIForThreadedRTS
@@ -42,7 +54,7 @@
 -- | Run an @IO@ parametrized interface description with Gtk backend
 runWidget
     :: forall n m . (MonadIO m, MonadIO n)
-    => Morph n IO
+    => (n () -> IO ())
     -> (IO () -> IO ())
     -> Morph IO IO
     -> Widget n m
@@ -52,6 +64,9 @@
     liftIO' :: MonadIO k => IO a -> k a
     liftIO' = liftIO . post
 
+--    nio = undefined
+
+    -- 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 .)
 
@@ -72,6 +87,101 @@
             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
+
+          (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
+            let
+              dims = do
+                win <- widgetGetDrawWindow canvas
+                (w, h) <- drawableGetSize win
+                let (w', h') = (fromIntegral w, fromIntegral h)
+                let sc = w' / sc_
+                return (sc, w', h', w, h)
+
+              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_
+                let dia = freeze $ clearValue dia_
+                (sc, w, h, wi, he) <- dims
+                win <- widgetGetDrawWindow canvas
+                drawWindowBeginPaintRect win $ Rectangle 0 0 wi he
+                renderWithDrawable win $ snd $ renderDia Cairo (CairoOptions "" (Width w) RenderOnly True) $ tr sc w h dia
+                drawWindowEndPaint win
+
+            return (draw, canvas, af, dims)
+
+          let -- compCoords :: (Double, Double) -> IO (MousePos a)
+              compCoords (x,y) = do
+                (sc, w, h, _, _) <- dims
+                d <- readMVar cur
+                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
+--                click <- eventClick
+                p <- eventCoordinates >>= liftIO . compCoords
+                liftIO $ re $ Click p
+              on' canvas buttonReleaseEvent $ tryEvent $ do
+--                click <- eventClick
+                p <- eventCoordinates >>= liftIO . compCoords
+                liftIO $ re $ Release p
+              on' canvas enterNotifyEvent $ tryEvent $ do
+                p <- eventCoordinates >>= liftIO . compCoords
+                liftIO $ re $ MouseEnter p
+              on' canvas leaveNotifyEvent $ tryEvent $ do
+                p <- eventCoordinates >>= liftIO . compCoords
+                liftIO $ re $ MouseLeave p
+              on' canvas motionNotifyEvent $ tryEvent $ do
+                p <- eventCoordinates >>= liftIO . compCoords
+                liftIO $ re $ MoveTo p
+              on' canvas scrollEvent $ tryEvent $ do
+                p <- eventCoordinates >>= liftIO . compCoords
+                dir <- eventScrollDirection
+                liftIO $ re $ ScrollTo dir p
+              on' canvas keyPressEvent $ tryEvent $ do
+--                p <- eventCoordinates >>= liftIO . compCoords
+                m <- eventModifier
+                c <- eventKeyVal
+                liftIO $ re $ KeyPress m c
+          _ <- liftIO $ on canvas exposeEvent $ tryEvent $ liftIO $ do
+                d <- readMVar cur'
+                case d of
+                    Just x -> putMVar v x
+                    _ -> return ()
+
+          canvasDraw' <- liftIO $ do
+            v2 <- newMVar False
+            forkIO $ do
+              threadDelay 200000
+              forever $ do
+                threadDelay 10000
+                dia <- takeMVar v
+                swapMVar cur' $ Just dia
+                swapMVar v2 True
+                let d = diaFun dia
+                post $ canvasDraw d
+                swapMVar v2 False
+                return ()
+            return $ \dia -> do
+                b <- readMVar v2
+                unless b $ do
+                    _ <- tryTakeMVar v
+                    putMVar v dia
+
+          ger nhd r canvasDraw'
+          return' af
+
         Button s sens col m -> do
             w <- liftIO' buttonNew
             hd <- reg m $ \re -> on' w buttonActivated $ re ()
@@ -92,8 +202,15 @@
             hd <- reg s $ \re -> on' w toggled $ toggleButtonGetActive w >>= re
             ger hd r $ toggleButtonSetActive w
             return' w
+        Scale a b c (r, s) -> do
+            w <- liftIO' $ hScaleNewWithRange a b c
+            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' $ flip mapM_ ss $ comboBoxAppendText w
             hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re
             ger hd r $ comboBoxSetActive w
diff --git a/src/LGtk.hs b/src/LGtk.hs
--- a/src/LGtk.hs
+++ b/src/LGtk.hs
@@ -2,44 +2,9 @@
 {-# LANGUAGE TypeFamilies #-}
 -- | Main LGtk interface.
 module LGtk
-    ( 
-    -- * Re-export
-
-    -- ** Category
-      Category (..)
-
-    -- ** Tensor
-    , Tensor (..)
-
-    -- ** Monad
-    , liftM
-    , liftM2
-    , liftM3
-    , when
-
-    -- * Lenses
-    -- ** Construction
-    , Lens (Lens)
-    , lens
-    , iso
-
-    -- ** Deconstruction
-    , runLens
-    , getL
-    , setL
-    , modL
-
-    -- ** Pure lenses
-    , fstLens
-    , sndLens
-    , listLens
-    , maybeLens
-
-    -- ** Impure lenses
-    , showLens
-
+    (
     -- * Monad morphisms
-    , Morph
+      Morph
     , HasReadPart (..)
 
     -- * References
@@ -98,6 +63,7 @@
     -- ** Running
     , Widget
     , runWidget
+--    , runWidget'
 
     -- ** GUI descriptions
     , label
@@ -111,6 +77,16 @@
     , notebook
     , cell_
     , action
+    , canvas
+    , Dia
+    , MouseEvent (..)
+    , MousePos (..)
+    , Modifier
+    , KeyVal
+    , keyName
+    , keyToChar
+    , ScrollDirection (..)
+    , hscale
 
     -- ** Derived constructs
     , empty
@@ -126,13 +102,11 @@
     ) where
 
 import Data.Maybe
-import Control.Category
-import Control.Category.Product
 import Control.Concurrent
 import Control.Monad
+import Control.Monad.Base
 import Control.Monad.State
 import Control.Monad.Trans.Identity
-import Prelude hiding ((.), id)
 import Data.Lens.Common
 
 import Control.Monad.ExtRef
@@ -142,6 +116,7 @@
 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
 
@@ -172,13 +147,32 @@
         join $ readChan actionChannel
         runPostActions
     Gtk.gtkContext $ \postGUISync -> do
-        widget <- runExtRef_ $ unliftIO $ \unlift ->
+        widget <- runExtRef_ $ unliftIO' $ \unlift ->
             evalRegister
                 (runIdentityT $ Gtk.runWidget unlift addPostAction postGUISync desc)
-                (liftIO . writeChan actionChannel . unlift)
+                (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
+
+    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
@@ -285,6 +279,10 @@
 action :: EffRef m => m (Widget m) -> Widget m
 action = Action
 
-
+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
+ -- = 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)
 
diff --git a/src/LGtk/ADTEditor.hs b/src/LGtk/ADTEditor.hs
--- a/src/LGtk/ADTEditor.hs
+++ b/src/LGtk/ADTEditor.hs
@@ -3,15 +3,18 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RankNTypes #-}
 -- | A generic ADT editor defined on top of the main LGtk interface, "LGtk".
 module LGtk.ADTEditor
-    ( List (..), Elems(..), ADTLens(..)
+    ( Lens_ (..), List (..), Elems(..), ADTLens(..)
     , adtEditor
     ) where
 
+import Control.Monad
+import Data.Lens.Common
 import LGtk
 
-import Prelude hiding ((.), id)
+newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}
 
 -- | Type-level lists
 data List a = Nil | Cons a (List a)
@@ -58,7 +61,7 @@
     The third parameter is a lens from the selected constructor index plus
     the values of the ADT parts to the ADT values.
     -}
-    adtLens :: ([(String, [Int])], Elems (ADTEls a), Lens (Int, Elems (ADTEls a)) a)
+    adtLens :: ([(String, [Int])], Elems (ADTEls a), Lens_ (Int, Elems (ADTEls a)) a)
 
 -- | A generic ADT editor
 adtEditor :: (EffRef m, ADTLens a) => Ref m a -> m (Widget m)
@@ -71,7 +74,7 @@
             , cell (liftM fst $ readRef q) $ \i -> vcat [es !! j | j <- snd $ ss !! i]
             ]
       where
-        (ss, ls, k) = adtLens
+        (ss, ls, Lens_ k) = adtLens
 
     mkEditors :: EffRef m => Elems xs -> Ref m (Elems xs) -> m [Widget m]
     mkEditors ElemsNil _ = return []
@@ -80,16 +83,18 @@
         is <- mkEditors xs $ lTail `lensMap` r
         return $ i : is
       where
+        lHead :: Lens' (Elems (Cons x xs)) x
         lHead = lens get set where
             get :: Elems (Cons x xs) -> x
             get (ElemsCons a _) = a
-            set :: x -> Elems (Cons x xs) -> Elems (Cons x xs)
-            set a (ElemsCons _ as) = ElemsCons a as
+            set :: Elems (Cons x xs) -> x -> Elems (Cons x xs)
+            set (ElemsCons _ as) a = ElemsCons a as
 
+        lTail :: Lens' (Elems (Cons x xs)) (Elems xs)
         lTail = lens get set where
             get :: Elems (Cons x xs) -> Elems xs
             get (ElemsCons _ as) = as
-            set :: Elems xs -> Elems (Cons x xs) -> Elems (Cons x xs)
-            set as (ElemsCons a _) = ElemsCons a as
+            set :: Elems (Cons x xs) -> Elems xs -> Elems (Cons x xs)
+            set (ElemsCons a _) as = ElemsCons a as
 
 
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
@@ -1,14 +1,18 @@
 -- | An integer list editor
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module LGtk.Demos.IntListEditor where
 
-import LGtk
-
+import Control.Monad
 import Data.List (sortBy)
 import Data.Function (on)
-import Prelude hiding ((.), id)
 
+import Data.Lens.Common
+import LGtk
+
 intListEditor
-    :: (EffRef m, Read a, Show a, Integral a)
+    :: forall m a
+    .  (EffRef m, Read a, Show a, Integral a)
     => (a, Bool)            -- ^ default element
     -> Int                  -- ^ maximum number of elements
     -> Ref m [(a, Bool)]    -- ^ state reference
@@ -27,13 +31,13 @@
                 , button (return "redo") redo
                 ]
             , hcat
-                [ smartButton (return "+1")         list $ map $ first (+1)
-                , smartButton (return "-1")         list $ map $ first (+(-1))
+                [ smartButton (return "+1")         list $ map $ modL fstLens (+1)
+                , smartButton (return "-1")         list $ map $ modL fstLens (+(-1))
                 , smartButton (return "sort")       list $ sortBy (compare `on` fst)
-                , smartButton (return "SelectAll")  list $ map $ second $ const True
+                , smartButton (return "SelectAll")  list $ map $ setL sndLens True
                 , smartButton (return "SelectPos")  list $ map $ \(a,_) -> (a, a>0)
                 , smartButton (return "SelectEven") list $ map $ \(a,_) -> (a, even a)
-                , smartButton (return "InvertSel")  list $ map $ second not
+                , smartButton (return "InvertSel")  list $ map $ modL sndLens not
                 , smartButton (liftM (("DelSel " ++) . show . length) sel) list $ filter $ not . snd
                 , smartButton (return "CopySel") safeList $ concatMap $ \(x,b) -> (x,b): [(x,False) | b]
                 , smartButton (return "+1 Sel")     list $ map $ mapSel (+1)
@@ -62,19 +66,23 @@
 
     sel = liftM (filter snd) $ readRef list
 
-    len = joinRef $ liftM ((`lensMap` safeList) . lens length . extendList) $ readRef range
-    extendList r n xs = take n $ (reverse . drop 1 . reverse) xs ++
-        (uncurry zip . (iterate (+ if r then 1 else 0) *** repeat)) (head $ reverse xs ++ [def])
+    len = joinRef $ liftM (\r -> ll r `lensMap` safeList) $ readRef range
+    ll :: Bool -> Lens' [(a, Bool)] Int
+    ll r = lens length extendList where
+        extendList xs n = take n $ (reverse . drop 1 . reverse) xs ++
+            (uncurry zip . (iterate (+ if r then 1 else 0) *** repeat)) (head $ reverse xs ++ [def])
 
     mapSel f (x, y) = (if y then f x else x, y)
 
+    (f *** g) (a, b) = (f a, g b)
+
 listEditor :: EffRef m => a -> [Ref m a -> m (Widget m)] -> Ref m [a] -> m (Widget m)
 listEditor def (ed: eds) r = do
     q <- extRef r listLens (False, (def, []))
     return $ cell (liftM fst $ readRef q) $ \b -> case b of
         False -> empty
         True -> action $ do
-            t1 <- ed $ fstLens . sndLens `lensMap` q
+            t1 <- ed $ sndLens . fstLens `lensMap` q
             t2 <- listEditor def eds $ sndLens . sndLens `lensMap` q
             return $ vcat [t1, t2]
 
diff --git a/src/LGtk/Demos/Main.hs b/src/LGtk/Demos/Main.hs
--- a/src/LGtk/Demos/Main.hs
+++ b/src/LGtk/Demos/Main.hs
@@ -1,9 +1,12 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module LGtk.Demos.Main
     ( main
     ) where
 
 import Data.Maybe (isJust)
-import Prelude hiding (id, (.))
+import Data.Lens.Common
+import Control.Monad
 
 import LGtk
 
@@ -142,19 +145,20 @@
 
     ]
 
-justLens :: a -> Lens (Maybe a) a
-justLens a = lens (maybe a id) (const . Just)
+justLens :: a -> Lens' (Maybe a) a
+justLens a = lens (maybe a id) (flip $ const . Just)
 
-counter :: (EffRef m, Ord a) => a -> Ref m (a, a) -> m (EqRef (Ref m) a)
+counter :: forall m a . (EffRef m, Ord a) => a -> Ref m (a, a) -> m (EqRef (Ref m) a)
 counter x ab = do
-    c <- extRef ab (sndLens . fix) (x, (x, x))
-    return $ fstLens . fix `lensMap` eqRef c
+    c <- extRef ab (fix . sndLens) (x, (x, x))
+    return $ fix . fstLens `lensMap` eqRef c
   where
-    fix = iso id $ \(x, ab@(a, b)) -> (min b $ max a x, ab)
+    fix :: Lens' (a, (a,a)) (a, (a,a))
+    fix = lens id $ \_ (x, ab@(a, b)) -> (min b $ max a x, ab)
 
 interval :: (Reference r, Ord a) => r (a, a) -> (r a, r a)
 interval ab = (lens fst set1 `lensMap` ab, lens snd set2 `lensMap` ab) where
-    set1 a (_, b) = (min b a, b)
-    set2 b (a, _) = (a, max a b)
+    set1 (_, b) a = (min b a, b)
+    set2 (a, _) b = (a, max a b)
 
 
diff --git a/src/LGtk/Demos/TEditor.hs b/src/LGtk/Demos/TEditor.hs
--- a/src/LGtk/Demos/TEditor.hs
+++ b/src/LGtk/Demos/TEditor.hs
@@ -3,8 +3,8 @@
 {-# LANGUAGE DataKinds #-}
 module LGtk.Demos.TEditor where
 
-import Prelude hiding ((.), id)
-
+import Data.Lens.Common
+import Control.Monad
 import LGtk
 import LGtk.ADTEditor
 
@@ -15,23 +15,23 @@
         deriving Show
 
 -- | Lens for @T@
-tLens :: Lens (Bool, (T, T)) T
+tLens :: Lens' (Bool, (T, T)) T
 tLens = lens get set where
     get (False, _)     = Leaf
     get (True, (l, r)) = Node l r
-    set Leaf (_, x)   = (False, x)
-    set (Node l r) _ = (True, (l, r))
+    set (_, x) Leaf  = (False, x)
+    set _ (Node l r) = (True, (l, r))
 
 -- | @ADTLens@ instance for @T@
 instance ADTLens T where
     type ADTEls T = Cons T (Cons T Nil)
-    adtLens = ([("Leaf",[]),("Node",[0,1])], ElemsCons Leaf (ElemsCons Leaf ElemsNil), lens get set) where
+    adtLens = ([("Leaf",[]),("Node",[0,1])], ElemsCons Leaf (ElemsCons Leaf ElemsNil), Lens_ $ lens get set) where
         get :: (Int, Elems (ADTEls T)) -> T
         get (0, _)     = Leaf
         get (1, ElemsCons l (ElemsCons r ElemsNil)) = Node l r
-        set :: T -> (Int, Elems (ADTEls T)) -> (Int, Elems (ADTEls T))
-        set Leaf (_, x)   = (0, x)
-        set (Node l r) _ = (1, ElemsCons l (ElemsCons r ElemsNil))
+        set :: (Int, Elems (ADTEls T)) -> T -> (Int, Elems (ADTEls T))
+        set (_, x) Leaf  = (0, x)
+        set _ (Node l r) = (1, ElemsCons l (ElemsCons r ElemsNil))
 
 -- | @T@ editor with comboboxes, as an ADTEditor
 tEditor1 :: EffRef m => Widget m
@@ -46,7 +46,7 @@
         , cell (liftM fst $ readRef q) $ \b -> case b of
             False -> empty
             True -> action $ do
-                t1 <- tEditor3 $ fstLens . sndLens `lensMap` q
+                t1 <- tEditor3 $ sndLens . fstLens `lensMap` q
                 t2 <- tEditor3 $ sndLens . sndLens `lensMap` q
                 return $ vcat [t1, t2]
         ]
diff --git a/src/LGtk/Demos/Tri.hs b/src/LGtk/Demos/Tri.hs
--- a/src/LGtk/Demos/Tri.hs
+++ b/src/LGtk/Demos/Tri.hs
@@ -4,10 +4,9 @@
 -}
 module LGtk.Demos.Tri where
 
+import Data.Lens.Common
 import LGtk
 
-import Prelude hiding ((.), id)
-
 -- | Information pieces: what is known?
 data S = X Int | Y Int | XY Int
 
@@ -18,10 +17,10 @@
 getXY s = head $ [x | XY x <- s]  ++ [getX  s + getY s]
 
 -- | Setter
-setX, setY, setXY :: Int -> [S] -> [S]
-setX  x s = take 2 $ X  x : filter (\x-> case x of X  _ -> False; _ -> True) s
-setY  x s = take 2 $ Y  x : filter (\x-> case x of Y  _ -> False; _ -> True) s
-setXY x s = take 2 $ XY x : filter (\x-> case x of XY _ -> False; _ -> True) s
+setX, setY, setXY :: [S] -> Int -> [S]
+setX  s x = take 2 $ X  x : filter (\x-> case x of X  _ -> False; _ -> True) s
+setY  s x = take 2 $ Y  x : filter (\x-> case x of Y  _ -> False; _ -> True) s
+setXY s x = take 2 $ XY x : filter (\x-> case x of XY _ -> False; _ -> True) s
 
 -- | The editor
 tri :: EffRef m => Widget m