lgtk 0.4 → 0.5

raw patch · 33 files changed

+2120/−1385 lines, 33 filesdep +data-lensdep +fsnotifydep +system-filepathdep −control-monad-freePVP ok

version bump matches the API change (PVP)

Dependencies added: data-lens, fsnotify, system-filepath, transformers

Dependencies removed: control-monad-free

API changes (from Hackage documentation)

Files

• lgtk.cabal +30/−21
• main/Main.hs +2/−31
• src/Control/MLens.hs +0/−77
• src/Control/MLens/ExtRef.hs +0/−68
• src/Control/MLens/ExtRef/Pure.hs +0/−112
• src/Control/MLens/ExtRef/Test.hs +0/−127
• src/Control/MLens/NewRef.hs +0/−65
• src/Control/MLens/NewRef/Unsafe.hs +0/−19
• src/Control/MLens/Unsafe.hs +0/−15
• src/Control/Monad/EffRef.hs +196/−0
• src/Control/Monad/ExtRef.hs +329/−0
• src/Control/Monad/ExtRef/Pure.hs +115/−0
• src/Control/Monad/ExtRef/Test.hs +288/−0
• src/Control/Monad/Register.hs +35/−0
• src/Control/Monad/Register/Basic.hs +96/−0
• src/Control/Monad/Restricted.hs +149/−0
• src/Data/MLens.hs +0/−196
• src/Data/MLens/Ref.hs +0/−106
• src/GUI/Gtk/Structures.hs +40/−0
• src/GUI/Gtk/Structures/IO.hs +152/−0
• src/GUI/MLens/Gtk.hs +0/−71
• src/GUI/MLens/Gtk/ADTEditor.hs +0/−62
• src/GUI/MLens/Gtk/Demos/IntListEditor.hs +0/−87
• src/GUI/MLens/Gtk/Demos/TEditor.hs +0/−66
• src/GUI/MLens/Gtk/Demos/Tri.hs +0/−41
• src/GUI/MLens/Gtk/IO.hs +0/−189
• src/GUI/MLens/Gtk/Interface.hs +0/−32
• src/LGtk.hs +280/−0
• src/LGtk/ADTEditor.hs +64/−0
• src/LGtk/Demos/IntListEditor.hs +82/−0
• src/LGtk/Demos/Main.hs +161/−0
• src/LGtk/Demos/TEditor.hs +57/−0
• src/LGtk/Demos/Tri.hs +44/−0

@@ -1,9 +1,9 @@ name:               lgtk-version:            0.4+version:            0.5 category:           GUI synopsis:           lens-based API for Gtk description:-    The main interface module of LGtk is "GUI.MLens.Gtk".+    The main interface module of LGtk is "LGtk".     .     See also <http://people.inf.elte.hu/divip/LGtk/index.html> stability:          experimental@@ -11,11 +11,16 @@ license-file:       LICENSE author:             Péter Diviánszky homepage:           http://people.inf.elte.hu/divip/LGtk/index.html+bug-reports:        http://hub.darcs.net/divip/lgtk/issues maintainer:         divipp@gmail.com cabal-version:      >= 1.8 build-type:         Simple +source-repository head+  type:             darcs+  location:         http://hub.darcs.net/divip/lgtk + library    hs-source-dirs:@@ -24,34 +29,38 @@                     base < 5                   , containers                   , directory+                  , system-filepath+                  , fsnotify +                  , data-lens+                  , transformers                   , mtl-                  , control-monad-free                    , gtk   exposed-modules:-                    Control.MLens-                    Control.MLens.Unsafe--                    GUI.MLens.Gtk-                    GUI.MLens.Gtk.ADTEditor+                    LGtk+                    LGtk.ADTEditor -                    GUI.MLens.Gtk.Demos.Tri-                    GUI.MLens.Gtk.Demos.IntListEditor-                    GUI.MLens.Gtk.Demos.TEditor+                    LGtk.Demos.Main+                    LGtk.Demos.Tri+                    LGtk.Demos.IntListEditor+                    LGtk.Demos.TEditor   other-modules:-                    Data.MLens-                    Data.MLens.Ref+                    Control.Monad.Restricted -                    Control.MLens.NewRef-                    Control.MLens.NewRef.Unsafe-                    Control.MLens.ExtRef-                    Control.MLens.ExtRef.Pure-                    Control.MLens.ExtRef.Test+                    Control.Monad.ExtRef+                    Control.Monad.ExtRef.Pure+                    Control.Monad.ExtRef.Test -                    GUI.MLens.Gtk.IO-                    GUI.MLens.Gtk.Interface+                    Control.Monad.Register+                    Control.Monad.Register.Basic++                    Control.Monad.EffRef++                    GUI.Gtk.Structures+                    GUI.Gtk.Structures.IO   ghc-options: +                    -threaded                     -Wall                      -fno-warn-incomplete-patterns                      -fno-warn-name-shadowing @@ -63,13 +72,13 @@    build-depends:                     base < 5-                  , mtl                   , lgtk   main-is:                     Main.hs   hs-source-dirs:                     main   ghc-options: +                    -threaded                     -Wall                      -fno-warn-incomplete-patterns                      -fno-warn-name-shadowing 

@@ -1,34 +1,5 @@-import Control.Monad-import Control.Monad.Trans -import Control.MLens.Unsafe (fileRef)-import GUI.MLens.Gtk--import GUI.MLens.Gtk.Demos.Tri-import GUI.MLens.Gtk.Demos.IntListEditor-import GUI.MLens.Gtk.Demos.TEditor-+import qualified LGtk.Demos.Main as LGtk ( main ) -{- |-We use @unsafeRunI@ only because we read from and write to a file.-It is considered unsafe usage, because the system do not guarantee that only this-program acesses the files at runtime.--} main :: IO ()-main = unsafeRunI $ Notebook-    [ (,) "IntListEditor" $ Action $ do-        state <- lift $ liftM (mapMLens lift) $ join $ liftM memoMLens $ fileRef "intListEditorState.txt"-        settings <- lift $ liftM (mapMLens lift) $ join $ liftM memoMLens $ fileRef "intListEditorSettings.txt"-        return $ intListEditor state settings-    , (,) "Tri" tri-    , (,) "T-Editor1" tEditor1-    , (,) "T-Editor3" $ Action $ newRef (iterate (Node Leaf) Leaf !! 10) >>= tEditor3-    ]-{--mainSafe :: IO ()-mainSafe = runI $ Notebook-    [ (,) "Tri" tri-    , (,) "T-Editor1" tEditor1-    , (,) "T-Editor3" $ Action $ newRef (iterate (Node Leaf) Leaf !! 10) >>= tEditor3-    ]--}+main = LGtk.main

@@ -1,77 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | The main monadic lens interface, ideally users should import only this module.-module Control.MLens-    ( -- * Data types-      MLens-    , Ref--    -- * Lens transformations-    , mapMLens-    , (.)-    , (***)-    , joinML-    , memoMLens--    -- * Lens destruction-    , runMLens-    , runRef--    -- * Lens construction-    , lensStore-    , NewRef (..)-    , ExtRef (..)-    , Ext, runExt, runExt_--    -- * Derived constructs-    -- ** Lens operations-    , getL, setL, modL-    , readRef, writeRef, modRef--    -- ** Pure lenses, defined with @lensStore@-    , id-    , unitLens-    , fstLens, sndLens-    , maybeLens-    , listLens-    , ithLens--    -- ** Impure lenses, defined with @lensStore@-    , forkLens-    , justLens-    , showLens--    -- ** Other derived construts-    , Lens-    , fromLens-    , toLens-    , lens-    , joinLens-    , undoTr-    , memoRead-    , memoWrite--    -- * Auxiliary definitions-    , Morph--    -- ** Consistency tests-    , testExt-    ) where--import Control.Category-import Control.Monad.Writer-import Prelude hiding ((.), id)--import Data.MLens-import Data.MLens.Ref-import Control.MLens.ExtRef-import Control.MLens.ExtRef.Test-import Control.MLens.ExtRef.Pure--newtype ExtTest i a = ExtTest { unExtTest :: Ext i (Writer [String]) a }-    deriving (Monad, MonadWriter [String], NewRef, ExtRef)---- | Consistency tests for @Ext@, should give an empty list of errors.-testExt :: [String]-testExt = mkTests (\t -> execWriter $ runExt $ unExtTest t)--

@@ -1,68 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Control.MLens.ExtRef-    ( module Control.MLens.NewRef-    -- * Monads with state expansion-    , ExtRef (extRef)-    -- * Applications-    , undoTr-    ) where----import Data.IORef-import Control.Monad-import Control.Category-import Prelude hiding ((.), id)--import Control.MLens.NewRef-import Data.MLens-import Data.MLens.Ref--{- |-Suppose that @r@ is a pure reference and @k@ is a pure lens.--The following laws should hold:-- *  @(extRef r k a0 >>= readRef)@ === @(readRef r >>= setL k a0)@-- *  @(extRef r k a0 >> readRef r)@ === @(readRef r)@--Given @s <- extRef r k a0@, the following laws should hold:-- *  @s@ is a pure reference-- *  @(k . s)@ === @r@--Law for @newRef@ when @extRef@ is defined:-- *  @(newRew x)@ === @(extRef unitLens unitLens x)@--For basic usage examples, look into the source of "Control.MLens.ExtRef.Pure.Test".--}-class NewRef m => ExtRef m where-    extRef :: Ref m b -> MLens m a b -> a -> m (Ref m a)----- | Undo-redo state transformation-undoTr-    :: ExtRef m =>-       (a -> a -> Bool)     -- ^ equality on state-    -> Ref m a              -- ^ reference of state-    -> m ( m (Maybe (m ()))   -         , m (Maybe (m ()))-         )  -- ^ undo and redo actions-undoTr eq r = do-    ku <- extRef r undoLens ([], [])-    let try f = liftM (fmap (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--

@@ -1,112 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{- |-Pure reference implementation for the @ExtRef@ interface.--The implementation uses @unsafeCoerce@ internally, but its effect cannot escape.--}-module Control.MLens.ExtRef.Pure-    ( Ext, runExt, runExt_-    ) where--import Control.Monad.State-import Control.Monad.Writer-import Control.Category-import qualified Control.Arrow as Arrow-import Data.Sequence-import Data.Foldable (toList)-import Prelude hiding ((.), id, splitAt, length)--import Unsafe.Coerce--import Data.MLens-import Data.MLens.Ref-import Control.MLens.ExtRef---data CC m x = forall a . CC a (a -> x -> m (a, x))--ap_ :: Monad m => x -> CC m x -> m (x, CC m x)-ap_ x (CC a set) = do-    (a', x') <- set a x-    return (x', CC a' set)--unsafeData :: CC m x -> a-unsafeData (CC x _) = unsafeCoerce x---newtype ST m = ST (Seq (CC m (ST m)))--initST :: ST m-initST = ST empty--extend_-    :: Monad m-    => (a -> ST m -> m (a, ST m))-    -> (a -> ST m -> m (a, ST m))-    -> a-    -> ST m-    -> ((ST m -> a, a -> ST m -> m (ST m)), ST m)-extend_ rk kr a0 x0-    = ((getM, setM), x0 ||> CC a0 kr)-  where-    getM = unsafeData . head . snd . limit x0--    setM a x = case limit x0 x of-        (zs, _ : ys) -> do-            (a', re) <- rk a zs-            foldM ((liftM (uncurry (||>)) .) . ap_) (re ||> CC a' kr) ys--    ST x ||> c = ST (x |> c)--    limit (ST x) (ST y) = ST Arrow.*** toList $ splitAt (length x) y----newtype Ext i m a = Ext { unExt :: StateT (ST m) m a }-    deriving (Functor, Monad, MonadWriter w)--instance MonadTrans (Ext i) where-    lift = Ext . lift--extRef_ :: Monad m => Ref (Ext i m) x -> MLens (Ext i m) a x -> a -> Ext i m (Ref (Ext i m) a)-extRef_ r1 r2 a0 = Ext $ do-    a1 <- g a0-    (t,z) <- state $ extend_ (runStateT . f) (runStateT . g) a1-    return $ MLens $ \c -> Ext (gets t) >>= \x -> return-            ( x-            , \a -> Ext $ (StateT $ liftM ((,) ()) . z a) >> return c-            )-   where-    f a = unExt $ getL r2 a >>= \x -> writeRef r1 x >> return a-    g b = unExt $ readRef r1 >>= flip (setL r2) b--instance (Monad m) => NewRef (Ext i m) where-    newRef = extRef_ unitLens unitLens--instance (Monad m) => ExtRef (Ext i m) where-    extRef = extRef_---- | Basic running of the @(Ext i m)@ monad.-runExt :: Monad m => (forall i . Ext i m a) -> m a-runExt s = evalStateT (unExt s) initST--{- |-Advanced running of the @(Ext i m)@ monad.--@Functor@ in contexts would not be needed if it were a superclass of @Monad@.--}-runExt_-    :: forall c m . (Functor m, NewRef m)-    => (forall n . (Monad n, Functor n) => Morph m n -> Morph n m -> c n -> c m)-    -> (forall i . c (Ext i m)) -> m (c m)-runExt_ mapI int = do-    vx <- newRef initST-    let unlift f = do-            x <- readRef vx-            (b, x) <- runStateT (unExt f) x-            writeRef vx x-            return b-    return $ mapI lift unlift int-

@@ -1,127 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}---{-# LANGUAGE FlexibleInstances #-}---{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Tests for the reference implementation of the @ExtRef@ interface.-module Control.MLens.ExtRef.Test-    ( -- * Basic test environment-      (==?)-    , (==>)-    -- * Test suit generation-    , mkTests-    , mkTests'-    ) where--import Control.Monad.Writer-import Control.Category-import Prelude hiding ((.), id)--import Data.MLens-import Data.MLens.Ref-import Control.MLens.ExtRef----------------------------------------------------------------------- | Check an equality.-(==?) :: (Eq a, Show a, MonadWriter [String] m) => a -> a -> m ()-rv ==? v = when (rv /= v) $ tell . return $ "runTest failed: " ++ show rv ++ " /= " ++ show v---- | Check the current value of a given reference.-(==>) :: (Eq a, Show a, MonadWriter [String] m) => Ref m a -> a -> m ()-r ==> v = readRef r >>= (==? v)--infix 0 ==>, ==?--newtype F m i a = F { unF :: m a } deriving (Monad, NewRef, ExtRef, MonadWriter w)---- | Simplified test generation-mkTests' :: (MonadWriter [String] m, ExtRef m) => (m () -> [String]) -> [String]-mkTests' f = mkTests $ \m -> f $ unF m--{- | -@mkTests@ generates a list of error messages which should be emtpy.--Look inside the sources for the tests.--}-mkTests :: ((forall i . (MonadWriter [String] (m i), ExtRef (m i)) => m i ()) -> [String]) -> [String]-mkTests runTest-      = newRefTest-     ++ writeRefTest-     ++ writeRefsTest-     ++ extRefTest-     ++ joinTest-     ++ joinTest2-     ++ undoTest-  where--    newRefTest = runTest $ do-        r <- newRef 3-        r ==> 3--    writeRefTest = runTest $ do-        r <- newRef 3-        r ==> 3-        writeRef r 4-        r ==> 4--    writeRefsTest = runTest $ do-        r1 <- newRef 3-        r2 <- newRef 13-        r1 ==> 3-        r2 ==> 13-        writeRef r1 4-        r1 ==> 4-        r2 ==> 13-        writeRef r2 0-        r1 ==> 4-        r2 ==> 0--    extRefTest = runTest $ do-        r <- newRef $ Just 3-        q <- extRef r maybeLens (False, 0)-        let q1 = fstLens . q-            q2 = sndLens . q-        r ==> Just 3-        q ==> (True, 3)-        writeRef r Nothing-        r ==> Nothing-        q ==> (False, 3)-        q1 ==> False-        writeRef q1 True-        r ==> Just 3-        writeRef q2 1-        r ==> Just 1--    joinTest = runTest $ do-        r2 <- newRef 5-        r1 <- newRef 3-        rr <- newRef r1-        r1 ==> 3-        let r = joinLens rr-        r ==> 3-        writeRef r1 4-        r ==> 4-        writeRef rr r2-        r ==> 5-        writeRef r1 4-        r ==> 5-        writeRef r2 14-        r ==> 14--    joinTest2 = runTest $ do-        r1 <- newRef 3-        rr <- newRef r1-        r2 <- newRef 5-        writeRef rr r2-        joinLens rr ==> 5--    undoTest = runTest $ do-        r <- newRef 3-        q <- extRef r (lens head (:)) []-        writeRef r 4-        q ==> [4, 3]----

@@ -1,65 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Control.MLens.NewRef-    ( -- * Monads with reference creation-      NewRef (newRef)--    -- * Memo operators-    , memoMLens--    -- * Auxiliary functions-    , memoRead, memoWrite-    ) where--import Control.Monad-import Control.Monad.Writer--import Data.MLens-import Data.MLens.Ref--{- |-Laws for @NewRef@:-- *  Any reference created by @newRef@ should satisfy the reference laws.--}-class (Monad m) => NewRef m where-    newRef :: a -> m (Ref m a)--instance (NewRef m, Monoid w) => NewRef (WriterT w m) where-    newRef = liftM (mapMLens lift) . lift . newRef---- | Memoise pure lenses-memoMLens :: (NewRef m, Eq a, Eq b) => MLens m a b -> m (MLens m a b)-memoMLens (MLens k) = do-    s <- newRef Nothing-    return $ MLens $ \a -> readRef s >>= \x -> do-        (b, bf) <- case x of-            Just (a', b, bf) | a' == a -> return (b, bf)-            _ -> k a >>= \(b, bf) -> do-                writeRef s $ Just (a, b, bf)-                return (b, bf)-        return (b-            , \b -> readRef s >>= \x -> case x of-                Just (a', b', _) | (a', b') == (a, b) -> return a-                Just (_, _, bf) -> bf b >>= \a -> do-                    writeRef s $ Just (a, b, bf)-                    return a-                _ -> bf b >>= \a -> do-                    writeRef s $ Just (a, b, bf)-                    return a-            )---memoRead :: NewRef m => m a -> m (m a)-memoRead g = liftM ($ ()) $ memoWrite $ const g--memoWrite :: (NewRef m, Eq b) => (b -> m a) -> m (b -> m a)-memoWrite g = do-    s <- newRef Nothing-    return $ \b -> readRef s >>= \x -> case x of-        Just (b', a) | b' == b -> return a-        _ -> g b >>= \a -> do-            writeRef s $ Just (b, a)-            return a---

@@ -1,19 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | This module export only the @NewRef@ instance for @IO@ which does not fulfil the @NewRef@ laws in a multi-threaded environment.-module Control.MLens.NewRef.Unsafe-    () where--import Data.IORef--import Data.MLens-import Control.MLens.NewRef---- | Note that this instance does not fulfil the @NewRef@ laws in a multi-threaded environment.-instance NewRef IO where-    newRef x = do-        r <- newIORef x-        return $ MLens $ \unit -> do-            x <- readIORef r-            return (x, \y -> writeIORef r y >> return unit)--

@@ -1,15 +0,0 @@--- | This module exports unsafe definitions, like the @NewRef@ instance for @IO@ which does not fulfil the @NewRef@ laws in a multi-threaded environment.-module Control.MLens.Unsafe-    ( -- * Unsafe references-      fileRef-    , fileRef_-    , logConsoleLens-    , logMLens-    -- * Auxiliary definitions-    , logFile-    ) where--import Data.MLens.Ref-import Control.MLens.NewRef.Unsafe ()--

@@ -0,0 +1,196 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.EffRef+    ( EffRef (..)+    , SafeIO (..)+    , EffIORef (..)+    , putStrLn_+    ) where++import Control.Concurrent+import Control.Exception (evaluate)+import Control.Monad+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+import Control.Monad.ExtRef++-- | Monad for dynamic actions+class ExtRef m => EffRef m where++    liftEffectM' :: Morph (EffectM m) m++    {- |+    Let @r@ be an effectless action (@ReadRef@ guarantees this).+    @onChange r fmm@ has the following effect:++    Whenever the value of @r@ changes (with respect to the given equality),+    @fmm@ is called with the new value @a@.+    The value of the @fmm a@ action is memoized,+    but the memoized value is run again and again.++    For example, let @(k :: a -> m b)@ and @(h :: b -> m ())@,+    and suppose that @r@ will have values @a1@, @a2@, @a3@ = @a1@.++    @onChange r $ \\a -> k a >>= return . h@++    has the effect++    @k a1 >>= \\b1 -> h b1 >> k a2 >>= \\b2 -> h b2 >> h b1@+    -}+    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 ())++    rEffect  :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()++-- | 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++    liftEffectM' = liftEffectM++    onChange init = toSend_ init . liftReadRef++    toReceive fm = toReceive_ (liftWriteRef . fm)++    rEffect init r f = onChange init r $ return . liftEffectM' . f++-- | 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.++    Note that @(asyncWrite 0 f a)@ acts immediately after the completion of the current computation,+    so it is safe, because the effect of @(f a)@ is not interleaved with+    the current computation.+    Although @(asyncWrite 0)@ is safe, code using it has a bad small.+    -}+    asyncWrite :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()++    {- |+    @fileRef path@ returns a reference which holds the actual contents+    of the file accessed by @path@.++    When the value of the reference changes, the file changes.+    When the file changes, the value of the reference changes.++    If the reference holds @Nothing@, the file does not exist.+    Note that you delete the file by putting @Nothing@ into the reference.    ++    Implementation note: The references returned by @fileRef@ are not+    memoised so currently it is unsafe to call @fileRef@ on the same filepath more than once.+    This restriction will be lifted in the future.+    -}+    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,+    @f s@ is called.+    -}+    getLine_   :: (String -> WriteRef m ()) -> m ()++    registerIO :: Eq a => (a -> WriteRef m ()) -> ((a -> IO ()) -> IO (Command -> IO ())) -> m ()++-- | @putStrLn_@ === @putStr_ . (++ "\n")@+putStrLn_ :: EffIORef m => String -> m ()+putStrLn_ = putStr_ . (++ "\n")++++-- | 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++    registerIO r fm = do+        _ <- toReceive r $ \x -> unliftIO $ \u -> liftM (fmap liftIO) $ liftIO $ fm $ u . x+        return ()++    asyncWrite t r a+        = registerIO r $ \re -> forkIOs [ threadDelay t, re a ]++    putStr_ = liftIO' . putStr++    getLine_ w = registerIO w $ \re -> do+        _ <- forkIO $ getLine >>= re+        return $ const $ return ()  -- TODO++    fileRef f = do+        ms <- liftIO' r+        ref <- newRef ms+        v <- liftIO' newEmptyMVar+        vman <- liftIO' newEmptyMVar+        cf <- liftIO' $ canonicalizePath f+        let+            cf' = decodeString cf+            g = (== cf')++            h = tryPutMVar v () >> return ()++            filt (Added x _) = g x+            filt (Modified x _) = g x+            filt (Removed x _) = g x++            act (Added _ _) = h+            act (Modified _ _) = h+            act (Removed _ _) = h++            startm = do+                man <- startManager+                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+            join $ takeMVar vman+            _ <- tryTakeMVar v+            w x+            startm+        return ref+     where+        r = do+            b <- doesFileExist f+            if b then do+                xs <- readFile f+                _ <- evaluate (length xs)+                return (Just xs)+             else return Nothing++        w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)+++--liftIO' :: EffIORef_ m => IO a -> m a+liftIO' m = liftEffectM $ liftIO m++forkForever :: IO () -> IO (Command -> IO ())+forkForever = forkIOs . repeat++forkIOs :: [IO ()] -> IO (Command -> IO ())+forkIOs ios = do+    x <- newMVar ()+    let g [] = return ()+        g (i:is) = do+            () <- takeMVar x+            putMVar x ()+            i+            g is+        f i Kill = killThread i+        f _ Block = takeMVar x+        f _ Unblock = putMVar x ()++    liftM f $ forkIO $ g ios+++

@@ -0,0 +1,329 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+module Control.Monad.ExtRef+    ( module Data.Lens.Common++    -- * Restricted monads+    , HasReadPart (..)++    -- * Reference class+    , Reference (..)++    -- * Ref construction class+    , ExtRef (..)++    -- * Derived constructs+    , ReadRef+    , WriteRef+    , modRef+    , liftReadRef+    , readRef'+    , undoTr+    , memoRead+    , memoWrite++    -- * References with equation+    , EqRef+    , eqRef+    , toRef+    , hasEffect++    -- * Auxiliary definitions+    , Morph+    , MorphD (..)+    , MonadIO' (..)++    -- * Auxiliary lens definitions+    , listLens+    , maybeLens+    , showLens++    -- * Re-exported+    , (.)+    , id+    ) where++import Control.Monad+import Control.Monad.Reader+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++{- |+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++    {- | @Refmonad r@  ===  @State s@++    Property derived from the 'HasReadPart' instance:++    @ReadPart (Refmonad r)@  ===  @Reader s@+    -}+    type RefMonad r :: * -> *++    {- | @readRef@ === @reader . getL@++    Properties derived from the 'HasReadPart' instance:++    @(readRef r >> return ())@ === @return ()@+    -}+    readRef  :: r a -> ReadPart (RefMonad r) a++    {- | @writeRef r@ === @modify . setL r@++    Properties derived from the set-get, get-set and set-set laws for lenses:++     *  @(readRef r >>= writeRef r)@ === @return ()@++     *  @(writeRef r a >> readRef r)@ === @return a@++     *  @(writeRef r a >> writeRef r a')@ === @writeRef r a'@+    -}+    writeRef :: r a -> a -> RefMonad r ()++    {- | Apply a lens on a reference.++    @lensMap@ === @(.)@+    -}+    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.+    It is not possible to create new reference dynamically with @joinRef@; for that, see 'onChange'.++    @joinRef@ === @Lens . join . (runLens .) . runReader@+    -}+    joinRef :: ReadPart (RefMonad r) (r a) -> r a++    -- | @unitRef@ === @lens (const ()) (const id)@+    unitRef :: r ()++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+++{- | 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.++@(Extref m) === (StateT s m)@, where 's' is an extendible state.++For basic usage examples, look into the source of @Control.Monad.ExtRef.Pure.Test@.+-}+class (Monad m, Reference (Ref m)) => ExtRef m where++    type Ref m :: * -> *++    -- | @'WriteRef' m@ is a submonad of @m@.+    liftWriteRef :: Morph (WriteRef m) m++    {- | Reference creation by extending the state of an existing reference.++    Suppose that @r@ is a reference and @k@ is a lens.++    Law 1: @extRef@ applies @k@ on @r@ backwards, i.e. +    the result of @(extRef r k a0)@ should behaves exactly as @(lensMap k r)@.++     *  @(liftM (k .) $ extRef r k a0)@ === @return r@++    Law 2: @extRef@ does not change the value of @r@:++     *  @(extRef r k a0 >> readRef r)@ === @(readRef r)@++    Law 3: Proper initialization of newly defined reference with @a0@:++     *  @(extRef r k a0 >>= readRef)@ === @(readRef r >>= setL k a0)@+    -}+    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)+++type WriteRef m = RefMonad (Ref m)++type ReadRef m = ReadPart (RefMonad (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++{- | @readRef@ lifted to the reference creation class.++@readRef'@ === @liftReadRef . readRef@+-}+readRef' :: ExtRef m => Ref m a -> m a+readRef' = liftReadRef . readRef++{- | Lazy monadic evaluation.+In case of @y <- memoRead x@, invoking @y@ will invoke @x@ at most once.++Laws:++ *  @(memoRead x >> return ())@ === @return ()@++ *  @(memoRead x >>= id)@ === @x@++ *  @(memoRead x >>= \y -> liftM2 (,) y y)@ === @liftM (\a -> (a, a)) y@++ *  @(memoRead x >>= \y -> liftM3 (,) y y y)@ === @liftM (\a -> (a, a, a)) y@++ *  ...+-}+memoRead :: ExtRef m => m a -> m (m a)+memoRead g = do+    s <- newRef Nothing+    return $ readRef' s >>= \x -> case x of+        Just a -> return a+        _ -> g >>= \a -> do+            liftWriteRef $ writeRef s $ Just a+            return a++memoWrite :: (ExtRef m, Eq b) => (b -> m a) -> m (b -> m a)+memoWrite g = do+    s <- newRef Nothing+    return $ \b -> readRef' s >>= \x -> case x of+        Just (b', a) | b' == b -> return a+        _ -> g b >>= \a -> do+            liftWriteRef $ writeRef s $ Just (b, a)+            return a+++-- | This instance is used in the implementation, end users do not need it.+instance (ExtRef m, Monoid w) => ExtRef (WriterT w m) where++    type Ref (WriterT w m) = Ref m++    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 =>+       (a -> a -> Bool)     -- ^ equality on state+    -> Ref m a             -- ^ reference of state+    ->   m ( ReadRef m (Maybe (WriteRef m ()))   +           , ReadRef m (Maybe (WriteRef m ()))+           )  -- ^ undo and redo actions+undoTr eq r = do+    ku <- extRef r undoLens ([], [])+    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+++data EqRef_ r a = forall b . Eq b => EqRef_ (r b) (Lens b a)++-- | References with inherent equivalence+newtype EqRef r a = EqRef { runEqRef :: ReadPart (RefMonad r) (EqRef_ r a) }++-- | @hasEffect@ is correct only if @eqRef@ is applied on a pure reference (a reference which is a pure lens on the hidden state).+eqRef :: (Reference r, Eq a) => r a -> EqRef r a+eqRef r = EqRef $ return $ EqRef_ r id++toRef :: Reference r => EqRef r a -> r a+toRef (EqRef m) = joinRef $ liftM (\(EqRef_ r k) -> k `lensMap` r) m++-- | @hasEffect r f@ returns @False@ iff @(modRef m f)@ === @(return ())@.+hasEffect+    :: Reference r+    => EqRef r a+    -> (a -> a)+    -> ReadPart (RefMonad r) Bool+hasEffect m f = runEqRef m >>= \(EqRef_ r k) -> liftM (\x -> modL k f x /= x) $ readRef r+++instance Reference r => Reference (EqRef r) where++    type (RefMonad (EqRef r)) = RefMonad r++    readRef = readRef . toRef++    writeRef = writeRef . toRef++    lensMap l (EqRef m) = EqRef $ m >>= \(EqRef_ r k) -> return $ EqRef_ r $ l . k++    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)++

@@ -0,0 +1,115 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+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++import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Identity+import Control.Category+import Control.Arrow ((***))+import Data.Sequence+import Data.Lens.Common+import Data.Foldable (toList)+import Prelude hiding ((.), id, splitAt, length)++import Unsafe.Coerce+import System.IO.Unsafe++import Control.Monad.Restricted+import Control.Monad.ExtRef+++instance Reference (Lens a) where++    type RefMonad (Lens a) = State a++    readRef = reader . getL++    writeRef r = modify . setL r++    lensMap = (.)++    unitRef = lens (const ()) (const id)++    joinRef = Lens . join . (runLens .) . runReader+++type LSt = Seq CC++initLSt :: LSt+initLSt = empty++data CC = forall a . CC (LSt -> a -> a) a++ap_ :: LSt -> CC -> CC+ap_ x (CC f a) = CC f (f x a)++unsafeData :: CC -> a+unsafeData (CC _ a) = unsafeCoerce a+++instance Monad m => ExtRef (StateT LSt m) where++    type Ref (StateT LSt m) = Lens LSt++    liftWriteRef = mapStateT (return . runIdentity)++    extRef 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))+          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+                (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+++-- | 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)+    -> m a+--    -> (Morph (Ext (State LSt) m) m -> Ext (State LSt) m a) -> m a+runExtRef_ f = newRef' initLSt >>= flip runExt f+++++

@@ -0,0 +1,288 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Tests for the @ExtRef@ interface.+module Control.Monad.ExtRef.Test+    ( -- * Tests for the interface+      mkTests+    -- * Tests for implementations+    , testExtPure+--    , testExtIORef+    ) where++import Control.Monad.Writer+import Control.Monad.Identity+import Control.Category+import Control.Arrow ((***))+import Data.Maybe+import Prelude hiding ((.), id)++import Control.Monad.ExtRef+import qualified Control.Monad.ExtRef.Pure as Pure+--import qualified Control.Monad.ExtRef.IORef as IORef++-----------------------------------------------------------------++-- | 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++{-+-- | Consistency tests for the @IORef@-based implementation of @Ext@, should give an empty list of errors.+testExtIORef :: [String]+testExtIORef = mkTests $ \t -> execWriter $ IORef.runExt t+    -- IORef.Ext i (Writer [String])+-}++-- | Check an equality.+(==?) :: (Eq a, Show a, MonadWriter [String] m) => a -> a -> m ()+rv ==? v = when (rv /= v) $ tell . return $ "runTest failed: " ++ show rv ++ " /= " ++ show v++-- | Check the current value of a given reference.+(==>) :: (Eq a, Show a, MonadWriter [String] m, ExtRef m) => Ref m a -> a -> m ()+r ==> v = readRef' r >>= (==? v)++infix 0 ==>, ==?++{- | +@mkTests@ generates a list of error messages which should be emtpy.++Look inside the sources for the tests.+-}+mkTests :: ((forall m . (MonadWriter [String] m, ExtRef m) => m ()) -> [String]) -> [String]+mkTests runTest+      = newRefTest+     ++ writeRefTest+     ++ writeRefsTest+     ++ extRefTest+     ++ joinTest+     ++ joinTest2+     ++ chainTest0+     ++ forkTest+     ++ forkTest2+     ++ chainTest+     ++ undoTest+     ++ undoTest2+     ++ undoTest3+  where++    newRefTest = runTest $ do+        r <- newRef 3+        r ==> 3++    writeRefTest = runTest $ do+        r <- newRef 3+        r ==> 3+        writeRef' r 4+        r ==> 4++    writeRefsTest = runTest $ do+        r1 <- newRef 3+        r2 <- newRef 13+        r1 ==> 3+        r2 ==> 13+        writeRef' r1 4+        r1 ==> 4+        r2 ==> 13+        writeRef' r2 0+        r1 ==> 4+        r2 ==> 0++    extRefTest = runTest $ do+        r <- newRef $ Just 3+        q <- extRef r maybeLens (False, 0)+        let q1 = fstLens `lensMap` q+            q2 = sndLens `lensMap` q+        r ==> Just 3+        q ==> (True, 3)+        writeRef' r Nothing+        r ==> Nothing+        q ==> (False, 3)+        q1 ==> False+        writeRef' q1 True+        r ==> Just 3+        writeRef' q2 1+        r ==> Just 1++    joinTest = runTest $ do+        r2 <- newRef 5+        r1 <- newRef 3+        rr <- newRef r1+        r1 ==> 3+        let r = joinRef' rr+        r ==> 3+        writeRef' r1 4+        r ==> 4+        writeRef' rr r2+        r ==> 5+        writeRef' r1 4+        r ==> 5+        writeRef' r2 14+        r ==> 14++    joinTest2 = runTest $ do+        r1 <- newRef 3+        rr <- newRef r1+        r2 <- newRef 5+        writeRef' rr r2+        joinRef' rr ==> 5++    chainTest0 = runTest $ do+        r <- newRef 1+        q <- extRef r id 0+        s <- extRef q id 0+        r ==> 1+        q ==> 1+        s ==> 1+        writeRef' r 2+        r ==> 2+        q ==> 2+        s ==> 2+        writeRef' q 3+        r ==> 3+        q ==> 3+        s ==> 3+        writeRef' s 4+        r ==> 4+        q ==> 4+        s ==> 4++    forkTest = runTest $ do+        r <- newRef 1+        q <- extRef r id 0+        s <- extRef r id 0+        r ==> 1+        q ==> 1+        s ==> 1+        writeRef' r 2+        r ==> 2+        q ==> 2+        s ==> 2+        writeRef' q 3+        r ==> 3+        q ==> 3+        s ==> 3+        writeRef' s 4+        r ==> 4+        q ==> 4+        s ==> 4++    forkTest2 = runTest $ do+        r <- newRef $ Just 1+        q <- extRef r maybeLens (False, 0)+        s <- extRef r maybeLens (False, 0)+        r ==> Just 1+        q ==> (True, 1)+        s ==> (True, 1)+        writeRef' r $ Just 2+        r ==> Just 2+        q ==> (True, 2)+        s ==> (True, 2)+        writeRef' r Nothing+        r ==> Nothing+        q ==> (False, 2)+        s ==> (False, 2)+        writeRef' (fstLens `lensMap` q) True+        r ==> Just 2+        q ==> (True, 2)+        s ==> (True, 2)+        writeRef' (sndLens `lensMap` q) 3+        r ==> Just 3+        q ==> (True, 3)+        s ==> (True, 3)+        writeRef' (fstLens `lensMap` q) False+        r ==> Nothing+        q ==> (False, 3)+        s ==> (False, 3)+        writeRef' (sndLens `lensMap` q) 4+        r ==> Nothing+        q ==> (False, 4)+        s ==> (False, 3)+        writeRef' (fstLens `lensMap` q) True+        r ==> Just 4+        q ==> (True, 4)+        s ==> (True, 4)+        writeRef' q (False, 5)+        r ==> Nothing+        q ==> (False, 5)+        s ==> (False, 4)+        writeRef' (fstLens `lensMap` s) True+        r ==> Just 4+        q ==> (True, 4)+        s ==> (True, 4)++    chainTest = runTest $ do+        r <- newRef $ Just $ Just 3+        q <- extRef r maybeLens (False, Nothing)+        s <- extRef (sndLens `lensMap` q) maybeLens (False, 0)+        r ==> Just (Just 3)+        q ==> (True, Just 3)+        s ==> (True, 3)+        writeRef' (fstLens `lensMap` s) False+        r ==> Just Nothing+        q ==> (True, Nothing)+        s ==> (False, 3)+        writeRef' (fstLens `lensMap` q) False+        r ==> Nothing+        q ==> (False, Nothing)+        s ==> (False, 3)+        writeRef' (fstLens `lensMap` s) True+        r ==> Nothing+        q ==> (False, Just 3)+        s ==> (True, 3)+        writeRef' (fstLens `lensMap` q) True+        r ==> Just (Just 3)+        q ==> (True, Just 3)+        s ==> (True, 3)++    undoTest = runTest $ do+        r <- newRef 3+        q <- extRef r (lens head (:)) []+        writeRef' r 4+        q ==> [4, 3]++    undoTest2 = runTest $ do+        r <- newRef 3+        q <- extRef r (lens head (:)) []+        q ==> [3]++    undoTest3 = runTest $ do+        r <- newRef 3+        (undo, redo) <- liftM (liftReadPart *** liftReadPart) $ undoTr (==) r+        r ==> 3+        redo === False+        undo === False+        writeRef' r 4+        r ==> 4+        redo === False+        undo === True+        writeRef' r 5+        r ==> 5+        redo === False+        undo === True+        push undo+        r ==> 4+        redo === True+        undo === True+        push undo+        r ==> 3+        redo === True+        undo === False+        push redo+        r ==> 4+        redo === True+        undo === True+        writeRef' r 6+        r ==> 6+        redo === False+        undo === True+      where+        push m = liftWriteRef m >>= \x -> maybe (return ()) liftWriteRef x+        m === t = liftWriteRef m >>= \x -> isJust x ==? t++    joinRef' r = joinRef $ readRef r++    writeRef' r a = liftWriteRef $ writeRef r a+

@@ -0,0 +1,35 @@+{-# 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+

@@ -0,0 +1,96 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Control.Monad.Register.Basic+    ( evalRegister+    , evalRegisterBasic+    ) where++import Control.Monad+import Control.Monad.RWS+import Data.List+import Prelude hiding ((.), id)++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 $ gets $ \memo -> case memo of+                Left b' | b' == b -> return ()+                Right ((b', (_, s1, s2, _, _)): _) | b' == b ->+                    runMonadMonoid $ s1 `mappend` s2+                _ -> 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 ()+                    runMorphD memoref $ state $ \memo ->+                        (,) () $ Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo+                    runMonadMonoid $ s1 `mappend` s2++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+++

@@ -0,0 +1,149 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+module Control.Monad.Restricted+    ( -- * Auxiliary definitions+      Morph+    , MorphD (..)+    , Ext (..), lift', runExt+    , HasReadPart (..)+    , MonadIO' (..)+    , SafeIO (..)+    , NewRef (..)+    , MonadMonoid (..)+    ) where++import Data.Monoid+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++{- |+Monad morphism. Think as @m@ is a submonad of @n@.+-}+type Morph m n = forall a . m a -> n a++{- |+The @MorphD@ type is needed only to avoid impredicative types.+We use @MorphD@ instead of @Morph@ when the morphism is stored inside a data structure.+-}+newtype MorphD m n = MorphD { runMorphD :: Morph m n }++-- | @m@ is a monad which 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 :: Morph (ReadPart m) m++-- | @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)++instance MonadTrans (Ext n) where+    lift = Ext . lift++lift' :: Monad m => n a -> Ext n m a+lift' m = Ext $ do+    r <- ask+    lift $ runMorphD r 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++instance MonadIO' (ReaderT r IO) where+    unliftIO f = do+        x <- ask+        f $ \m -> runReaderT m x++-- | Type class for effectless, synchronous @IO@ actions.+class Monad m => SafeIO m where++    -- | The program's command line arguments (not including the program name). +    getArgs     :: m [String]++    -- | The name of the program as it was invoked.+    getProgName :: m String++    -- | @getEnv var@ returns the value of the environment variable @var@.+    lookupEnv   :: String -> m (Maybe String)++-- | This instance is used in the implementation, the end users do not need it.+instance SafeIO IO where++    getArgs     = Env.getArgs+    getProgName = Env.getProgName+    lookupEnv   = Env.lookupEnv++-- | 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' :: forall a . a -> m (MorphD (State a) m)++instance NewRef IO where+    newRef' x = do+        vx <- liftIO $ newMVar x+        return $ MorphD $ \m -> liftIO $ modifyMVar vx $ return . swap . runState m+      where+        swap (a, b) = (b, a)++instance NewRef m => NewRef (Ext n m) where+    newRef' a = liftM (\m -> MorphD $ lift . runMorphD m) $ lift $ newRef' a+++newtype MonadMonoid a = MonadMonoid { runMonadMonoid :: a () }++instance Monad m => Monoid (MonadMonoid m) where+    mempty = MonadMonoid $ return ()+    MonadMonoid a `mappend` MonadMonoid b = MonadMonoid $ a >> b++

@@ -1,196 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Data.MLens-    ( -- * Monadic lenses data type-      MLens (..)--    -- * Side-effect free lenses-    , Lens-    , fromLens, toLens--    -- * Lens construction-    , lensStore-    , lens--    -- * Lens operations-    , getL, setL, modL--    -- * Lens transformations-    , (***)-    , mapMLens-    , joinML, joinLens--    -- * Pure lenses-    , unitLens-    , fstLens, sndLens-    , maybeLens-    , listLens-    , ithLens--    -- * Impure lenses-    , forkLens-    , justLens-    , showLens--    -- * Auxiliary definitions-    , Morph-    ) where--import Data.Monoid-import Control.Category-import qualified Control.Arrow as Arrow-import Control.Monad-import Control.Monad.Identity-import Data.Maybe-import Prelude hiding ((.), id)--{-|-Monadic lenses.--Laws for pure monadic lenses:-- *  set-get: @(setL l b a >>= getL l)@ === @(setL l b a >> return b)@-- *  get-set: @(getL l a >>= \b -> setL l b a)@  ===  @(return a)@-- *  set-set: @(setL l b a >>= setL l b')@ ===  @(setL l b' a)@--For example, @fstLens@ and @(fstLens . fstLens)@ fulfil these laws.--Using lenses which do not fulfil the lens laws are safe,-but one should take extra care when doing program transformations-or reasoning about code with impure lenses.--The following law is a minimum, but some lenses (which do logging) do not fulfil this:-- *  get-no-effect: @(getL k a >> return ())@ === @(return ())@--TODO: List laws, document which laws hold for each lenses.--}-newtype MLens m a b-    = MLens { runMLens :: a -> m (b, b -> m a) }-{--The following representations would be also good for @(MLens m a b)@:-- *  @a -> m (Store b (m a))@-- *  @forall f . Functor f => (b -> m (f (m b))) -> a -> m (f (m a))@-- *  @(a -> m b, b -> a -> m a)@--The last representation has no efficient composition operation-(the set operation on composition of n lenses use O(n * n) get operations with the last representation).--}--{-|-Side-effect free lenses.--The following representations would be also good for @(Lens a b)@:-- *  @forall m . Monad m => MLens m a b@--}-type Lens a b-    = MLens Identity a b--fromLens :: Monad m => Lens a b -> MLens m a b-fromLens = mapMLens (return . runIdentity)--toLens :: (forall m . Monad m => MLens m a b) -> Lens a b-toLens k = k---- | Impure (but effect-free) lens constuctor-lensStore :: Monad m => (a -> (b, b -> a)) -> MLens m a b-lensStore f = MLens $ return . g . f where-    g (b, ba) = (b, return . ba)---- | Impure (but effect-free) lens constuctor, defined with @lensStore@.-lens :: Monad m => (a -> b) -> (b -> a -> a) -> MLens m a b-lens get set = lensStore $ \a -> (get a, flip set a)--getL :: Monad m => MLens m a b -> a -> m b-getL k a = runMLens k a >>= return . fst--setL :: Monad m => MLens m a b -> b -> a -> m a-setL k b a = runMLens k a >>= ($ b) . snd--modL :: Monad m => MLens m b a -> (a -> a) -> b -> m b-modL k f b = do-    (x, h) <- runMLens k b-    h (f x)--instance Monad m => Category (MLens m) where-    id = MLens $ \a -> return (a, return)-    MLens r1 . MLens r2 = MLens $ \a -> do-        (g2, s2) <- r2 a-        (g1, s1) <- r1 g2-        return (g1, s1 >=> s2)---- | Tensor product------ could be defined as------ @instance Monad m => Tensor (MLens m)@------ @Tensor@ is defined in "Control.Category.Product" in the data-lens package.-(***) :: Monad m => MLens m a b -> MLens m c d -> MLens m (a, c) (b, d)-MLens r1 *** MLens r2 = MLens $ \(a1, a2) -> do-        (g1, s1) <- r1 a1-        (g2, s2) <- r2 a2-        return-            ( (g1, g2)-            , uncurry (liftM2 (,)) . (s1 Arrow.*** s2)-            )--infixr 3 ***--mapMLens :: (Monad m, Monad n) => Morph m n -> MLens m a b -> MLens n a b-mapMLens f (MLens r) = MLens $ \a -> do-    (x, s) <- f (r a)-    return (x, f . s)--joinML :: Monad m => (a -> m (MLens m a b)) -> MLens m a b-joinML r = MLens $ \x -> r x >>= ($ x) . runMLens---- | It would be possible to define a @Monad@ instance for @(MLens m a)@ too, but monad laws would not hold.-joinLens :: Monad m => MLens m a (MLens m a b) -> MLens m a b-joinLens = joinML . getL--unitLens :: Monad m => MLens m a ()-unitLens = lens (const ()) (const id)--fstLens :: Monad m => MLens m (a,b) a-fstLens = lens fst $ \a (_,b) -> (a,b)--sndLens :: Monad m => MLens m (a,b) b-sndLens = lens snd $ \b (a,_) -> (a,b)--maybeLens :: Monad m => MLens m (Bool, a) (Maybe a)-maybeLens = lens (\(b,a) -> if b then Just a else Nothing)-              (\x (_,a) -> maybe (False, a) (\a' -> (True, a')) x)--listLens :: Monad m => MLens m (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))---- | @ithLens@ is pure only with proper preconditions.-ithLens :: Monad m => Int -> MLens m [a] a-ithLens i = lens (!!i) $ \x xs -> take i xs ++ x : drop (i+1) xs--forkLens :: (Monoid a, Monad m) => MLens m a (a, a)-forkLens = lens (\a -> (a, a)) $ \(a1, a2) _ -> a1 `mappend` a2--justLens :: Monad m => a -> MLens m (Maybe a) a-justLens a = lens (maybe a id) (const . Just)--showLens :: (Monad m, Show a, Read a) => MLens m a String-showLens = lens show $ \s def -> maybe def fst $ listToMaybe $ reads s---type Morph m n = forall a . m a -> n a-----

@@ -1,106 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Data.MLens.Ref-    ( Unit--    -- * Data type for reference lenses-    , Ref--    -- * Reference operations-    , runRef-    , readRef, writeRef, modRef--    -- * Some impure @IO@ referenceses-    , fileRef, fileRef_-    , logConsoleLens--    -- * Auxiliary definitions-    , logMLens, logFile-    ) where--import Control.Monad-import Control.Category-import System.Directory-import Prelude hiding ((.), id)--import Data.MLens--{- | -The abstract data type @Unit@ is isomorphic to @()@,-but by making it abstract we can prevent using the same reference-on both sides of lens composition, which would have surprising effects.--}-data Unit = Unit deriving (Eq, Show)--{- |-Laws for pure references:-- *  @(readRef r >> return ())@ === @(return ())@-- *  @(readRef r >>= writeRef r)@ === @(return ())@-- *  @(writeRef r a >> readRef r)@ === @(return a)@-- *  @(writeRef r a >> writeRef r a')@ === @(writeRef r a')@--These laws are equivalent to the get-no-effect, set-get, get-set and set-set laws for monadic lenses.--Reference lenses can be composed with lenses.-For example, if--@r :: Ref m (a,b)@--then--@fstLens . r :: Ref m a@--}-type Ref m a = MLens m Unit a--runRef :: Monad m => Ref m a -> m (a, a -> m ())-runRef r = liftM f $ runMLens r Unit where-    f (a, m) = (a, \a -> m a >> return ())--readRef :: Monad m => Ref m a -> m a-readRef = liftM fst . runRef--writeRef :: Monad m => Ref m a -> a -> m ()-writeRef r a = runRef r >>= ($ a) . snd--modRef :: Monad m => Ref m a -> (a -> a) -> m ()-k `modRef` f = runRef k >>= \(a, m) -> m $ f a---- | Using @fileRef@ is safe if the file is not used concurrently.-fileRef :: FilePath -> IO (Ref IO String)-fileRef f = liftM (justLens "" .) $ fileRef_ f---- | Note that if you write @Nothing@, the file is deleted.-fileRef_ :: FilePath -> IO (Ref IO (Maybe String))-fileRef_ f = return $ MLens $ \unit -> do-    b <- doesFileExist f-    if b then do-            xs <- readFile f-            length xs `seq` return (Just xs, wr unit)-         else return (Nothing, wr unit)- where-    wr unit mb = do-        maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f) mb-        return unit--logMLens :: Monad m => (a -> m ()) -> (a -> m ()) -> MLens m a a-logMLens getLog setLog = MLens $ \a -> getLog a >> return (a, \b -> setLog b >> return b)--{- |-@logConsoleLens@ logs elementary get and set operations.--Note that with the current representation of @MLens@, every set operation involves a get operation.--}-logConsoleLens :: (Show a) => MLens IO a a-logConsoleLens = logMLens (putStrLn . ("Get: " ++) . show) (putStrLn . ("Set: " ++) . show)--logFile :: FilePath -> IO (String -> IO ())-logFile f = do-    b <- doesFileExist f-    when (not b) $ writeFile f ""-    return $ appendFile f---

@@ -0,0 +1,40 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+-- | Lens-based Gtk interface+module GUI.Gtk.Structures+    ( Send+    , Receive+    , SendReceive+    , Widget (..)+    , ListLayout (..)+    , Color (..)+    ) where++--import Graphics.UI.Gtk (Color)+import Graphics.UI.Gtk.Gdk.GC (Color (Color))++import Control.Monad.Register (Command (..))++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)++-- | Widget descriptions+data Widget n m+    = 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 ()+             }  -- ^ 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++data ListLayout+    = Horizontal | Vertical+

@@ -0,0 +1,152 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+module GUI.Gtk.Structures.IO+    ( runWidget+    , gtkContext+    ) where++import Control.Category+import Control.Monad+import Control.Monad.Writer+import Control.Concurrent+import Data.Maybe+import Prelude hiding ((.), id)++import Graphics.UI.Gtk hiding (Widget)+import qualified Graphics.UI.Gtk as Gtk++import Control.Monad.Restricted (Morph)+import Control.Monad.Register (Command (..))+import GUI.Gtk.Structures++gtkContext :: (Morph IO IO -> IO SWidget) -> IO ()+gtkContext m = do+    _ <- unsafeInitGUIForThreadedRTS+    tid <- myThreadId+    let post :: Morph IO IO+        post e = do+            tid' <- myThreadId+            if tid' == tid then e else postGUISync e+    c <- m post+    window <- windowNew+    set window [ containerBorderWidth := 10, containerChild := snd c ]+    _ <- window `on` deleteEvent $ liftIO mainQuit >> return False+    widgetShowAll window+    mainGUI++type SWidget = (IO (), Gtk.Widget)++-- | Run an @IO@ parametrized interface description with Gtk backend+runWidget+    :: forall n m . (MonadIO m, MonadIO n)+    => Morph n IO+    -> (IO () -> IO ())+    -> Morph IO IO+    -> Widget n m+    -> m SWidget+runWidget nio post' post = toWidget+ where+    liftIO' :: MonadIO k => IO a -> k a+    liftIO' = liftIO . post++    reg :: Receive n m a -> Receive IO m a+    reg s f = liftM (nio .) $ s $ liftM (fmap liftIO) . liftIO' . f . (nio .)++    ger :: (Command -> IO ()) -> Send n m a -> Send IO m a+    ger hd s f = s $ \a -> liftIO' $ do+        hd Block+        f a+        hd Unblock++    nhd :: Command -> IO ()+    nhd = const $ return ()++    toWidget :: Widget n m -> m SWidget+    toWidget i = case i of++        Action m -> m >>= toWidget+        Label s -> do+            w <- liftIO' $ labelNew Nothing+            ger nhd s $ labelSetLabel w+            return' w+        Button s sens col m -> do+            w <- liftIO' buttonNew+            hd <- reg m $ \re -> on' w buttonActivated $ re ()+            ger hd s $ buttonSetLabel w+            ger hd sens $ widgetSetSensitive w+            ger hd col $ \c -> do+                widgetModifyBg w StateNormal c+                widgetModifyBg w StatePrelight c+            return' w+        Entry (r, s) -> do+            w <- liftIO' entryNew+            hd <- reg s $ \re -> on' w entryActivate $ entryGetText w >>= re+            ger hd r $ entrySetText w+            return' w+        Checkbox (r, s) -> do+            w <- liftIO' checkButtonNew+            hd <- reg s $ \re -> on' w toggled $ toggleButtonGetActive w >>= re+            ger hd r $ toggleButtonSetActive w+            return' w+        Combobox ss (r, s) -> do+            w <- liftIO' comboBoxNewText+            liftIO' $ flip mapM_ ss $ comboBoxAppendText w+            hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re+            ger hd r $ comboBoxSetActive w+            return' w+        List o xs -> do+            ws <- mapM toWidget xs+            w <- liftIO' $ case o of+                Vertical -> fmap castToBox $ vBoxNew False 1+                Horizontal -> fmap castToBox $ hBoxNew False 1+            shs <- forM ws $ liftIO' . containerAdd'' w . snd+            liftM (mapFst (sequence_ shs >>)) $ return'' ws w+        Notebook' s xs -> do+            ws <- mapM (toWidget . snd) xs+            w <- liftIO' notebookNew+            forM_ (zip ws xs) $ \(ww, (s, _)) -> do+                liftIO' . flip (notebookAppendPage w) s $ snd $ ww+            _ <- reg s $ \re -> on' w switchPage $ re+            return'' ws w+        Cell onCh f -> do+            let b = False+            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 +                    _ <- swapMVar sh x+                    containerForeach w $ if b then widgetHideAll else containerRemove w +                    post' $ post $ do+                        ch <- containerGetChildren w+                        when (y `notElem` ch) $ containerAdd w y+                        x+            liftM (mapFst (join (readMVar sh) >>)) $ return'' [] w++on' :: GObjectClass x => x -> Signal x c -> c -> IO (Command -> IO ())+on' o s c = liftM (flip f) $ on o s c where+    f Kill = signalDisconnect+    f Block = signalBlock+    f Unblock = signalUnblock++return' :: Monad m => WidgetClass x => x -> m SWidget+return' w = return (widgetShowAll w, castToWidget w)++return'' :: Monad m => WidgetClass x => [SWidget] -> x -> m SWidget+return'' ws w = return (mapM_ fst ws >> widgetShow w, castToWidget w)++mapFst f (a, b) = (f a, b)++containerAdd'' w x = do+    a <- alignmentNew 0 0 0 0+    containerAdd a x+    containerAdd w a+    set w [ boxChildPacking a := PackNatural ]+    return $ widgetShow a++

@@ -1,71 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}--- | The main LGtk interface, ideally users should import only this module.-module GUI.MLens.Gtk-    ( -- * Lenses and references-      module Control.MLens--    -- * GUI combinators-    , I (..)-    , ListLayout (..)--    -- * Running GUI descriptions-    , runI-    , unsafeRunI--    -- * Derived constructs-    , vcat, hcat-    , smartButton--    -- * Auxiliary functions-    , toFree-    ) where--import Control.Category-import Control.Monad.Free-import Prelude hiding ((.), id)--import Control.MLens-import GUI.MLens.Gtk.Interface-import qualified GUI.MLens.Gtk.IO as Gtk--vcat :: [I m] -> I m-vcat = List Vertical--hcat :: [I m] -> I m-hcat = List Horizontal--smartButton-  :: (Eq a, Monad m, Functor m) =>-     Free m String -> (a -> m a) -> Ref m a -> I m-smartButton s f k =-    Button s $ toFree $ readRef k >>= \x -> f x >>= \y -> -        if y == x then return Nothing else return $ Just ((readRef k >>= f) >>= writeRef k)---- | Run an interface description-runI :: (forall m . (Functor m, ExtRef m) => I m) -> IO ()-runI e = runExt_ mapI e >>= Gtk.runI---- | Run an interface description------ Unsafe only if you do nasty things in the @IO@ monad, like forking threads-unsafeRunI :: (forall i . I (Ext i IO)) -> IO ()-unsafeRunI e = runExt_ mapI e >>= Gtk.runI---mapI :: (Monad m, Functor m, Monad n, Functor n) => Morph n m -> Morph m n -> I m -> I n-mapI _g f (Label s)     = Label $ mapFree f s-mapI _g f (Button s m)  = Button (mapFree f s) (mapFree f $ fmap (fmap f) m)-mapI _g f (Entry m)     = Entry $ mapMLens f m-mapI _g f (Checkbox m)  = Checkbox $ mapMLens f m-mapI _g f (Combobox ss m) = Combobox ss $ mapMLens f m-mapI g f (List o is)    = List o $ map (mapI g f) is-mapI g f (Notebook is)  = Notebook $ map (fmap $ mapI g f) is-mapI g f (Cell b m k)   = Cell b (f m) $ mapI g f . k-mapI g f (Action m)     = Action $ f $ liftM (mapI g f) m---toFree :: (Functor m, Monad m) => m a -> Free m a-toFree = Impure . fmap Pure--

@@ -1,62 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-module GUI.MLens.Gtk.ADTEditor-    ( List (..), Elems(..), ADTLens(..)-    , adtEditor-    ) where--import GUI.MLens.Gtk--import Control.Monad-import Prelude hiding ((.), id)---- | Type-level lists-data List a = Nil | Cons a (List a)---- | Heterogeneous lists-data Elems (xs :: List *) where-    ElemsNil :: Elems Nil-    ElemsCons :: ADTLens a => a -> Elems as -> Elems (Cons a as)---- | Lens for editable ADTs-class ADTLens a where-    type ADTEls a :: List *-    adtLens :: ([(String, [Int])], Elems (ADTEls a), Lens (Int, Elems (ADTEls a)) a)---- | A generic ADT editor-adtEditor :: (ExtRef m, ADTLens a) => Ref m a -> m (I m)-adtEditor = liftM Action . memoRead . editor  where-    editor r = do-        q <- extRef r (fromLens k) (0, ls)-        es <- mkEditors ls $ sndLens . q-        return $ hcat-            [ Combobox (map fst ss) $ fstLens . q-            , Cell True (liftM fst $ readRef q) $ \i -> vcat [es !! j | j <- snd $ ss !! i]-            ]-      where-        (ss, ls, k) = adtLens--    mkEditors :: ExtRef m => Elems xs -> Ref m (Elems xs) -> m [I m]-    mkEditors ElemsNil _ = return []-    mkEditors (ElemsCons _ xs) r = do-        i <- adtEditor $ lHead . r-        is <- mkEditors xs $ lTail . r-        return $ i : is-      where-        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--        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--

@@ -1,87 +0,0 @@--- | An integer list editor-module GUI.MLens.Gtk.Demos.IntListEditor where--import GUI.MLens.Gtk--import Control.Monad-import qualified Control.Arrow as Arrow-import Data.List-import Data.Function (on)-import Prelude hiding ((.), id)-------------------intListEditor-    :: (Functor m, ExtRef m)-    => Ref m String         -- ^ state reference-    -> Ref m String         -- ^ settings reference-    -> I m-intListEditor state settings = Action $ do-    list <- extRef state showLens []-    (undo, redo)  <- undoTr ((==) `on` map fst) list-    range <- extRef settings showLens True-    let safe = lens id (const . take maxi)-        len = joinML $ \_ -> readRef range >>= \r -> return $ lens length $ extendList r . min maxi-        sel = liftM (filter snd) $ readRef list-    return $ Notebook-        [ (,) "Editor" $ vcat-            [ hcat-                [ Entry $ showLens . len . list-                , smartButton (return "+1") (modL len (+1))      list-                , smartButton (return "-1") (modL len (+(-1)))   list-                , smartButton (toFree $ liftM (("DeleteAll " ++) . show) $ readRef $ len . list) (modL len $ const 0) list-                , Button (return "undo") $ toFree undo-                , Button (return "redo") $ toFree redo-                ]-            , hcat-                [ sbutton (return "+1")         (map $ mapFst (+1))           list-                , sbutton (return "-1")         (map $ mapFst (+(-1)))        list-                , sbutton (return "sort")       (sortBy (compare `on` fst))   list-                , sbutton (return "SelectAll")  (map $ mapSnd $ const True)   list-                , sbutton (return "SelectPos")  (map $ \(a,_) -> (a, a>0))    list-                , sbutton (return "SelectEven") (map $ \(a,_) -> (a, even a)) list-                , sbutton (return "InvertSel")  (map $ mapSnd not)            list-                , sbutton (toFree $ liftM (("DelSel " ++) . show . length) sel) (filter $ not . snd) list-                , smartButton (return "CopySel") (modL safe $ concatMap $ \(x,b) -> (x,b): [(x,False) | b]) list-                , sbutton (return "+1 Sel")     (map $ mapSel (+1))           list-                , sbutton (return "-1 Sel")     (map $ mapSel (+(-1)))        list-                ]-            , Label $ toFree $ liftM (("Sum: " ++) . show . sum . map fst) sel-            , Action $ listEditor def (itemEditor list) list-            ]-        , (,) "Settings" $ hcat-            [ Label $ return "Create range"-            , Checkbox range-            ]-        ]- where-    itemEditor list i r = return $ hcat-        [ Label $ return $ show (i+1) ++ "."-        , Entry $ showLens . fstLens . r-        , Checkbox $ sndLens . r-        , Button (return "Del")  $ return $ Just $ modRef list (\xs -> take i xs ++ drop (i+1) xs)-        , Button (return "Copy") $ return $ Just $ modRef list (\xs -> take (i+1) xs ++ drop i xs) ]--    extendList r n xs = take n $ (reverse . drop 1 . reverse) xs ++-        (uncurry zip . ((if r then enumFrom else repeat) Arrow.*** repeat)) (head $ reverse xs ++ [def])--    def = (0, True)-    maxi = 15--    sbutton s f k = smartButton s (return . f) k--    mapFst f (x, y) = (f x, y)-    mapSnd f (x, y) = (x, f y)-    mapSel f (x, y) = (if y then f x else x, y)---listEditor :: ExtRef m => a -> (Int -> Ref m a -> m (I m)) -> Ref m [a] -> m (I m)-listEditor def ed = editor 0 where-  editor i r = liftM Action $ memoRead $ do-    q <- extRef r listLens (False, (def, []))-    t1 <- ed i $ fstLens . sndLens . q-    t2 <- editor (i+1) $ sndLens . sndLens . q-    return $ Cell True (liftM fst (readRef q)) $ \b -> vcat $ if b then [t1, t2] else []---

@@ -1,66 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-module GUI.MLens.Gtk.Demos.TEditor where--import Control.Monad-import Prelude hiding ((.), id)--import GUI.MLens.Gtk-import GUI.MLens.Gtk.ADTEditor---- | Binary tree shapes-data T-    = Leaf-    | Node T T-        deriving Show---- | Lens for @T@-tLens :: Monad m => MLens m (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))---- | @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-        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))---- | @T@ editor with comboboxes, as an ADTEditor-tEditor1 :: (Functor m, ExtRef m) => I m-tEditor1 = Action $ newRef Leaf >>= adtEditor---- | @T@ editor with checkboxes, given directly-tEditor2 :: ExtRef m => I m-tEditor2 = Action $ liftM editor $ newRef Leaf  where--    editor r = Action $ do-        q <- extRef r tLens (False, (Leaf, Leaf))-        return $ hcat-            [ Checkbox $ fstLens . q-            , Cell True (liftM fst (readRef q)) $ \b -> vcat $ -                  [ editor $ fstLens . sndLens . q | b ]-               ++ [ editor $ sndLens . sndLens . q | b ]-            ]---- | Another @T@ editor with checkboxes, given directly-tEditor3 :: ExtRef m => Ref m T -> m (I m)-tEditor3 = liftM Action . memoRead . editor' where-    editor' r = do-        q <- extRef r tLens (False, (Leaf, Leaf))-        t1 <- tEditor3 $ fstLens . sndLens . q-        t2 <- tEditor3 $ sndLens . sndLens . q-        return $ hcat-            [ Checkbox $ fstLens . q-            , Cell True (liftM fst $ readRef q) $ \b -> vcat $ [t1 | b] ++ [t2 | b]-            ]--

@@ -1,41 +0,0 @@-{- |-An editor for integers x, y, z such that x + y = z always hold and-the last edited value change.--}-module GUI.MLens.Gtk.Demos.Tri where--import GUI.MLens.Gtk--import Control.Monad-import Prelude hiding ((.), id)---- | Information pieces: what is known?-data S = X Int | Y Int | XY Int---- | Getter-getX, getY, getXY :: [S] -> Int-getX s =  head $ [x | X  x <- s]  ++ [getXY s - getY s]-getY s =  head $ [x | Y  x <- s]  ++ [getXY s - getX s]-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---- | The editor-tri :: (Functor m, ExtRef m) => I m-tri = Action $ do-    s <- newRef [X 0, Y 0]-    return $ vcat-        [ hcat [Entry $ showLens . lens getX setX . s, Label $ return "x"]-        , hcat [Entry $ showLens . lens getY setY . s, Label $ return "y"]-        , hcat [Entry $ showLens . lens getXY setXY . s, Label $ return "x + y"]-        ]------

@@ -1,189 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module GUI.MLens.Gtk.IO-    ( runI-    ) where--import Control.Category-import Control.Monad-import Control.Monad.Writer-import Control.Monad.Free-import Data.Maybe-import Prelude hiding ((.), id)--import Graphics.UI.Gtk--import Control.MLens-import Control.MLens.Unsafe ()-import GUI.MLens.Gtk.Interface------------------------ | (remove action, toggle action, show action)-type WriterState = (IO (), IO (), IO ())--type IOWriterState = WriterT WriterState IO---- | Run an @IO@ parametrized interface description with Gtk backend-runI :: I IO -> IO ()-runI i = do-    _ <- initGUI-    dca <- newRef []-    rea <- newRef True-    (c, _) <- runWriterT $ userr_ rea dca i-    window <- windowNew-    set window [ containerBorderWidth := 10, containerChild := c ]-    _ <- window `on` deleteEvent $ liftIO (mainQuit) >> return False-    widgetShowAll window-    mainGUI- where-    userr_ :: Ref IO Bool -> Ref IO [Ref IO (Maybe (Bool, IO ()))] -> I IO -> IOWriterState Widget-    userr_ rea dca i = case i of-        Button s m -> do-            w <- lift'' buttonNew-            lift $ evalFree (maybe (return ()) ((\x -> on w buttonActivated x >> return ()) . react))-                        ((\x -> on w buttonActivated x >> return ()) . react . join . fmap (maybe (return ()) id) . join . fmap (induce id)) m-            s >>=.. buttonSetLabel w-            fmap isJust m >>=.. widgetSetSensitive w-            return' w-        Entry k -> do-            w <- lift'' entryNew-            _ <- lift $ on w entryActivate $ react $ entryGetText w >>= writeRef k-            readRef k >>=. entrySetText w-            return' w-        Checkbox k -> do-            w <- lift'' checkButtonNew-            _ <- lift $ on w toggled $ react $ toggleButtonGetActive w >>= writeRef k-            readRef k >>=. toggleButtonSetActive w-            return' w-        Combobox ss k -> do-            w <- lift'' comboBoxNewText-            lift $ flip mapM_ ss $ comboBoxAppendText w-            _ <- lift $ on w changed $ react $ fmap (max 0) (comboBoxGetActive w) >>= writeRef k -            readRef k >>=. comboBoxSetActive w-            return' w-        List o xs -> do-            w <- lift' $ case o of-                Vertical -> fmap castToBox $ vBoxNew False 1-                Horizontal -> fmap castToBox $ hBoxNew False 1-            flip mapM_ xs $ flattenI' >=> containerAdd'' w-            return' w-        Notebook xs -> do-            w <- lift' notebookNew-            flip mapM_ xs $ \(s, i) ->-                flattenI' i >>= lift . flip (notebookAppendPage w) s-            return' w-        Label s -> do-            w <- lift'' $ labelNew Nothing-            s >>=.. labelSetLabel w-            return' w-        Action m -> -            lift m >>= flattenI'-        Cell False m f -> do-            w <- lift' $ alignmentNew 0 0 1 1-            cancelc <- lift $ newRef mempty-            togglec <- lift $ newRef mempty-            showc <- lift $ newRef mempty-            let cc = (readRef cancelc >>= id) >> writeRef cancelc mempty >> writeRef togglec mempty >> writeRef showc mempty-            let cc' = readRef togglec >>= id-            let cc'' = readRef showc >>= id-            tell (cc, cc', cc'')-            m >>=. \new -> do-                cc-                containerForeach w $ containerRemove w-                (x, (c1, c2, c3)) <- runWriterT $ flattenI' (f new)-                writeRef cancelc c1-                writeRef togglec c2-                writeRef showc c3-                containerAdd w x-                widgetShowAll w-            return' w-        Cell True m f -> do-            w <- lift' $ hBoxNew False 1-            tri <- lift $ newRef []-            cancelc <- lift $ newRef mempty-            togglec <- lift $ newRef mempty-            showc <- lift $ newRef mempty-            let cc = (readRef cancelc >>= id) >> writeRef cancelc mempty >> writeRef togglec mempty >> writeRef showc mempty-            let cc' = readRef togglec >>= id-            let cc'' = readRef showc >>= id-            tell (cc, cc', cc'')-            m >>=. \new -> do-                cc'-                containerForeach w $ widgetHideAll-                t <- readRef tri-                case [b | (a,b) <-t, a == new] of-                    [] -> do-                        (x, (c1, c2, c3)) <- runWriterT $ flattenI' $ f new-                        modRef cancelc (>> c1)-                        containerAdd w x-                        widgetShowAll x-                        modRef tri ((new, (c2, c3)) :)-                        writeRef togglec c2-                        writeRef showc c3-                    [(c2, c3)] -> do-                        c2-                        c3-                        writeRef togglec c2-                        writeRef showc c3-            return' w-      where-        flattenI' = userr_ rea dca--        infixl 1 >>=.., >>=.--        m >>=.. f = evalFree (lift . f) ((>>=. f) . join . fmap (induce id)) m--        (>>=.) :: (Eq a) => IO a -> (a -> IO ()) -> IOWriterState ()-        get >>=. install = lift get >>= \x -> do-            v <- lift $ newRef x-            b <- lift $ newRef $ Just $ (,) True $ do-                x <- readRef v-                x' <- get-                when (x /= x') $ do-                    writeRef v x'-                    install x'-                    return ()-            lift $ modRef dca (b :)-            tell (writeRef b Nothing, modRef b $ fmap $ mapFst not, mempty)-            lift $ install x--        react :: IO () -> IO ()-        react a = do-            b <- readRef rea-            when b $ do-            writeRef rea False-            a-            xs <- readRef dca-            writeRef dca ([] :: [Ref IO (Maybe (Bool, IO ()))])-            let ff (Just (b, m)) = when b m >> return True-                ff Nothing = return False-            xs' <- filterM ((>>= ff) . readRef) . reverse $ xs-            modRef dca (++ reverse xs') -            writeRef rea True--    return' :: GObjectClass x => x -> IOWriterState Widget-    return' = return . castToWidget--    lift' m = do-        x <- lift m-        tell (mempty, mempty, widgetShow (castToWidget x))-        return x--    lift'' m = do-        x <- lift m-        tell (mempty, mempty, widgetShowAll (castToWidget x))-        return x--    containerAdd'' w x = do-        a <- lift' $ alignmentNew 0 0 0 0-        lift $ containerAdd a x-        lift $ containerAdd w a-        lift $ set w [ boxChildPacking a := PackNatural ]--mapFst f (a, b) = (f a, b)--instance Monoid (IO ()) where-    mempty = return ()-    mappend = (>>)--

@@ -1,32 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--- | Lens-based Gtk interface-module GUI.MLens.Gtk.Interface-    ( I (..)-    , ListLayout (..)-    ) where--import Control.Monad.Free--import Control.MLens---- | Interface description parametrized by a monad-data I m-    = Label (Free m String)     -- ^ label-    | Button { label_  :: Free m String-             , action_ :: Free m (Maybe (m ()))     -- ^ when the @Maybe@ value is @Nothing@, the button is inactive-             }  -- ^ button-    | Checkbox (Ref m Bool)         -- ^ checkbox-    | Combobox [String] (Ref m Int) -- ^ combo box-    | Entry (Ref m String)          -- ^ entry field-    | List ListLayout [I m]         -- ^ group interfaces into row or column-    | Notebook [(String, I m)]      -- ^ tabs-    | forall a . Eq a -    => Cell { remember_content_   :: Bool       -- ^ remember the content or not? (info for the renderer)-            , underlying_value_   :: m a-            , dynamic_interface_  :: a -> I m-            }     -- ^ dynamic interface-    | Action (m (I m))              -- ^ do an action before giving the interface--data ListLayout-    = Horizontal | Vertical-

@@ -0,0 +1,280 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | Main LGtk interface.+module LGtk+    ( +    -- * Categories+      Category (..)+    , Tensor (..)+    , liftM++    -- * Lenses+    -- ** Construction+    , Lens (Lens)+    , lens+    , iso++    -- ** Deconstruction+    , runLens+    , getL+    , setL+    , modL++    -- ** Pure lenses+    , fstLens+    , sndLens+    , listLens+    , maybeLens++    -- ** Impure lenses+    , showLens++    -- * Monad morphisms+    , Morph+    , HasReadPart (..)++    -- * References+    -- ** Basic operations+    , Reference+    , RefMonad+    , readRef+    , writeRef+    , lensMap+    , joinRef+    , unitRef++    -- ** Reference creation+    , ExtRef+    , Ref+    , extRef+    , newRef+    , ReadRef+    , WriteRef+    , liftReadRef++    -- ** Derived constructs+    , modRef+    , readRef'+    , memoRead+    , undoTr++    , EqRef+    , eqRef+    , toRef+    , hasEffect++    -- * Dynamic networks+    , EffRef+    , onChange++    -- * I/O+    , SafeIO+    , getArgs+    , getProgName+    , lookupEnv++    , EffIORef+    , asyncWrite+    , putStr_+    , getLine_+    , fileRef++    -- ** Derived constructs+    , putStrLn_++    -- * GUI++    -- ** Running+    , Widget+    , runWidget++    -- ** GUI descriptions+    , label+    , button_+    , Color (..)+    , checkbox+    , combobox+    , entry+    , vcat+    , hcat+    , notebook+    , cell_+    , action++    -- ** Derived constructs+    , empty+    , entryShow+    , button+    , smartButton+    , cell+    , cellNoMemo++    -- ** Experimental+    , button__++    ) where++import Data.Maybe+import Control.Category+import Control.Category.Product+import Control.Concurrent+import Control.Monad+import Control.Monad.State+import Control.Monad.Trans.Identity+import Prelude hiding ((.), id)+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 Control.Monad.ExtRef.Pure+import Control.Monad.Restricted+++{- |+Gtk widget descriptions.+Construction of a @(w :: forall m . EffIORef m => Widget m)@ value is side-effect free,+side-effects happen at running @('runWidget' w)@.++@Widget m@ should be abstract, 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++{- |+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 m) -> IO ()+runWidget e = do+    post_ <- newRef' $ return ()+    let post' = runMorphD post_ . modify . flip (>>)+    ch <- newChan+    _ <- forkIO $ forever $ do+        join $ readChan ch+        join $ runMorphD post_ $ state $ \m -> (m, return ())+    Gtk.gtkContext $ \post ->+        runExtRef_ $ unliftIO $ \u ->+            evalRegister+                (        runIdentityT $+                    Gtk.runWidget u post' post e)+                (liftIO . writeChan ch . u)++-- | Vertical composition of widgets.+vcat :: [Widget m] -> Widget m+vcat = List Vertical++-- | Horizontal composition of widgets.+hcat :: [Widget m] -> Widget m+hcat = List Horizontal++-- | Empty widget.+empty :: Widget m+empty = hcat []++-- | Dynamic label.+label :: EffRef m => ReadRef m String -> Widget m+label = Label . rEffect True++-- | Low-level button with changeable background color.+button__+    :: EffRef m+    => ReadRef m String     -- ^ dynamic label of the button+    -> ReadRef m Bool       -- ^ the button is active when this returns @True@+    -> 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)++-- | Low-level button.+button_+    :: EffRef m+    => ReadRef m String     -- ^ dynamic label of the button+    -> 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+    :: 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)++++smartButton+    :: EffRef m+    => ReadRef m String     -- ^ dynamic label of the button+    -> EqRef (Ref m) 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.+    -> Widget m+smartButton s m f+    = button_ s (hasEffect m f) (modRef m f)++-- | Checkbox.+checkbox :: EffRef m => Ref m Bool -> Widget m+checkbox r = 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)++-- | Text entry.+entry :: EffRef m => Ref m String -> Widget m+entry r = Entry (rEffect True (readRef r), toReceive $ writeRef r)++-- | Text entry.+entryShow :: (EffRef m, Show a, Read a) => Ref m a -> Widget m+entryShow r = entry $ showLens `lensMap` r++{- | Notebook (tabs).++The tabs are created lazily.+-}+notebook :: EffRef m => [(String, Widget m)] -> Widget m+notebook xs = Action $ do+    currentPage <- newRef 0+    let f index (title, w) = (,) title $ cell (liftM (== index) $ readRef currentPage) $ \b -> case b of+           False -> hcat []+           True -> w+    return $ Notebook' (toReceive $ writeRef currentPage) $ zipWith f [0..] xs++{- | Dynamic cell.++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++{- | Dynamic cell.++The inner widgets are memoised.+-}+cell :: (EffRef m, Eq a) => ReadRef m a -> (a -> Widget m) -> Widget m+cell r m = cell_ r $ \mk -> liftM return . mk . m++{- | Dynamic cell.++The inner widgets are not memoised.+-}+cellNoMemo :: (EffRef m, Eq a) => ReadRef m a -> (a -> Widget m) -> Widget m+cellNoMemo r m = cell_ r $ \mk -> return . mk . m++-- | @action@ makes possible to do any 'EffRef' action while creating the widget.+action :: EffRef m => m (Widget m) -> Widget m+action = Action++++

@@ -0,0 +1,64 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+module LGtk.ADTEditor+    ( List (..), Elems(..), ADTLens(..)+    , adtEditor+    ) where++import LGtk++import Control.Monad+import Prelude hiding ((.), id)++-- | Type-level lists+data List a = Nil | Cons a (List a)++-- | Heterogeneous lists+data Elems (xs :: List *) where+    ElemsNil :: Elems Nil+    ElemsCons :: ADTLens a => a -> Elems as -> Elems (Cons a as)++-- | Lens for editable ADTs+class ADTLens a where+    type ADTEls a :: List *+    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)+adtEditor = liftM action . memoRead . editor  where+    editor r = do+        q <- extRef r k (0, ls)+        es <- mkEditors ls $ sndLens `lensMap` q+        return $ hcat+            [ combobox (map fst ss) $ fstLens `lensMap` q+            , cell (liftM fst $ readRef q) $ \i -> vcat [es !! j | j <- snd $ ss !! i]+            ]+      where+        (ss, ls, k) = adtLens++    mkEditors :: EffRef m => Elems xs -> Ref m (Elems xs) -> m [Widget m]+    mkEditors ElemsNil _ = return []+    mkEditors (ElemsCons _ xs) r = do+        i <- adtEditor $ lHead `lensMap` r+        is <- mkEditors xs $ lTail `lensMap` r+        return $ i : is+      where+        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++        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++

@@ -0,0 +1,82 @@+-- | An integer list editor+module LGtk.Demos.IntListEditor where++import LGtk++import Data.List (sortBy)+import Data.Function (on)+import Prelude hiding ((.), id)++intListEditor+    :: (EffRef m, Read a, Show a, Integral a)+    => (a, Bool)            -- ^ default element+    -> Int                  -- ^ maximum number of elements+    -> Ref m [(a, Bool)]    -- ^ state reference+    -> Ref m Bool           -- ^ settings reference+    -> Widget m+intListEditor def maxi list_ range = action $ do+    (undo, redo)  <- undoTr ((==) `on` map fst) list_+    return $ notebook+        [ (,) "Editor" $ vcat+            [ hcat+                [ entryShow $ toRef len+                , smartButton (return "+1") len (+1)+                , smartButton (return "-1") len (+(-1))+                , smartButton (liftM (("DeleteAll " ++) . show) $ readRef $ toRef len) len $ const 0+                , button (return "undo") undo+                , button (return "redo") redo+                ]+            , hcat+                [ smartButton (return "+1")         list $ map $ first (+1)+                , smartButton (return "-1")         list $ map $ first (+(-1))+                , smartButton (return "sort")       list $ sortBy (compare `on` fst)+                , smartButton (return "SelectAll")  list $ map $ second $ const 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 (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)+                , smartButton (return "-1 Sel")     list $ map $ mapSel (+(-1))+                ]+            , label $ liftM (("Sum: " ++) . show . sum . map fst) sel+            , action $ listEditor def (map itemEditor [0..]) list_+            ]+        , (,) "Settings" $ hcat+            [ label $ return "Create range"+            , checkbox range+            ]+        ]+ where+    list = eqRef list_++    itemEditor i r = return $ hcat+        [ label $ return $ show (i+1) ++ "."+        , entryShow $ fstLens `lensMap` r+        , checkbox $ sndLens `lensMap` r+        , button_ (return "Del")  (return True) $ modRef list $ \xs -> take i xs ++ drop (i+1) xs+        , button_ (return "Copy") (return True) $ modRef list $ \xs -> take (i+1) xs ++ drop i xs+        ]++    safeList = lens id (const . take maxi) `lensMap` list++    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])++    mapSel f (x, y) = (if y then f x else x, y)++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+            t2 <- listEditor def eds $ sndLens . sndLens `lensMap` q+            return $ vcat [t1, t2]+++

@@ -0,0 +1,161 @@+module LGtk.Demos.Main+    ( main+    ) where++import Control.Monad+import Data.Maybe+import Prelude hiding (id, (.))++import LGtk++import LGtk.Demos.Tri+import LGtk.Demos.IntListEditor+import LGtk.Demos.TEditor++main :: IO ()+main = runWidget $ notebook+    [ (,) "Hello" $ label $ return "Hello World!"++    , (,) "Counters" $ notebook++        [ (,) "Unbounded" $ action $ do+            c <- newRef 0+            return $ vcat+                [ label $ liftM show $ readRef c+                , hcat+                    [ smartButton (return "+1") (eqRef c) (+1)+                    , smartButton (return "-1") (eqRef c) (+(-1))+                    ]+                ]++        , (,) "1..3" $ action $ do+            c <- newRef 1+            return $ vcat+                [ label $ liftM show $ readRef c+                , hcat+                    [ smartButton (return "+1") (eqRef c) $ min 3 . (+1)+                    , smartButton (return "-1") (eqRef c) $ max 1 . (+(-1))+                    ]+                ]++        , (,) "a..b" $ action $ do+            ab <- newRef (1, 3)+            let (a, b) = interval ab+            c <- counter 0 ab+            return $ vcat+                [ label $ liftM show $ readRef $ toRef c+                , hcat+                    [ smartButton (return "+1") c (+1)+                    , smartButton (return "-1") c (+(-1))+                    ]+                , hcat [ label $ return "min", entryShow a ]+                , hcat [ label $ return "max", entryShow b ]+                ]++        ]++    , (,) "Buttons" $ action $ do+        x <- newRef 0+        let is = [0, 65535 `div` 2, 65535]+            colorlist = liftM3 Color is is is+            f n = colorlist !! (n `mod` length colorlist)+        return $ button__ (return "Push") (return True) (liftM f $ readRef x) $ modRef x (+1)++    , (,) "Tabs" $ notebook++        [ (,) "TabSwitch" $ action $ do+            x <- newRef "a"+            let w = vcat [ label $ readRef x, entry x ]+            return $ notebook+                [ (,) "T1" w+                , (,) "T2" w+                ]++        ]++    , (,) "Async" $ action $ do+        ready <- newRef True+        delay <- newRef 1.0+        onChange False (readRef ready) $ \b -> return $ case b of+            True -> return ()+            False -> do+                d <- readRef' delay+                asyncWrite (ceiling $ 10^6 * d) (writeRef ready) True+        return $ vcat+            [ hcat [ entryShow delay, label $ return "sec" ]+            , button_ (readRef delay >>= \d -> return $ "Start " ++ show d ++ " sec computation")+                      (readRef ready)+                      (writeRef ready False)+            , label $ liftM (\b -> if b then "Ready." else "Computing...") $ readRef ready+            ]++    , (,) "Timer" $ action $ do+        t <- newRef 0+        onChange True (readRef t) $ \ti -> return $ asyncWrite (10^6) (writeRef t) (1 + ti) +        return $ vcat+            [ label $ liftM show $ readRef t+            ]++    , (,) "System" $ notebook++        [ (,) "Args" $ action $ getArgs >>= \args -> return $ label $ return $ unlines args++        , (,) "ProgName" $ action $ getProgName >>= \args -> return $ label $ return args++        , (,) "Env" $ action $ do+            v <- newRef "HOME"+            return $ vcat+                [ entry v+                , label $ readRef v >>= liftM (maybe "Not in env." show) . lookupEnv +                ]++        , (,) "Std I/O" $ let+            put = action $ do+                x <- newRef ""+                onChange False (readRef x) $ return . putStrLn_+                return $ hcat +                    [ label $ return "putStrLn"+                    , entry x+                    ]+            get = action $ do+                ready <- newRef $ Just ""+                onChange False (liftM isJust $ readRef ready) $ \b -> +                    return $ when (not b) $ getLine_ $ writeRef ready . Just+                return $ hcat +                    [ button_ (return "getLine") (liftM isJust $ readRef ready) $ writeRef ready Nothing+                    , label $ liftM (maybe "<<<waiting for input>>>" id) $ readRef ready+                    ]+           in vcat [ put, put, put, get, get, get ]+        ]++    , (,) "IntListEditor" $ action $ do+        state <- fileRef "intListEditorState.txt"+        list <- extRef (justLens "" `lensMap` state) showLens []+        settings <- fileRef "intListEditorSettings.txt"+        range <- extRef (justLens "" `lensMap` settings) showLens True+        return $ intListEditor (0, True) 15 list range++    , (,) "Tri" tri++    , (,) "T-Editor1" tEditor1++    , (,) "T-Editor3" $ action $ newRef (iterate (Node Leaf) Leaf !! 10) >>= tEditor3++    ]++justLens :: a -> Lens (Maybe a) a+justLens a = lens (maybe a id) (const . Just)++counter :: (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+  where+    fix = iso 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)++

@@ -0,0 +1,57 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+module LGtk.Demos.TEditor where++import Control.Monad+import Prelude hiding ((.), id)++import LGtk+import LGtk.ADTEditor++-- | Binary tree shapes+data T+    = Leaf+    | Node T T+        deriving Show++-- | Lens for @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))++-- | @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+        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))++-- | @T@ editor with comboboxes, as an ADTEditor+tEditor1 :: EffRef m => Widget m+tEditor1 = action $ newRef Leaf >>= adtEditor++-- | @T@ editor with checkboxes, given directly+tEditor3 :: EffRef m => Ref m T -> m (Widget m)+tEditor3 r = do+    q <- extRef r tLens (False, (Leaf, Leaf))+    return $ hcat+        [ checkbox $ fstLens `lensMap` q+        , cell (liftM fst $ readRef q) $ \b -> case b of+            False -> empty+            True -> action $ do+                t1 <- tEditor3 $ fstLens . sndLens `lensMap` q+                t2 <- tEditor3 $ sndLens . sndLens `lensMap` q+                return $ vcat [t1, t2]+        ]++

@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{- |+An editor for integers x, y, z such that x + y = z always hold and+the last edited value change.+-}+module LGtk.Demos.Tri where++import LGtk++import Control.Monad+import Prelude hiding ((.), id)++-- | Information pieces: what is known?+data S = X Int | Y Int | XY Int++-- | Getter+getX, getY, getXY :: [S] -> Int+getX s =  head $ [x | X  x <- s]  ++ [getXY s - getY s]+getY s =  head $ [x | Y  x <- s]  ++ [getXY s - getX s]+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++-- | The editor+tri :: EffRef m => Widget m+tri = action $ do+    s <- newRef [X 0, Y 0]+    return $ vcat+        [ hcat [entryShow $ lens getX setX `lensMap` s, label $ return "x"]+        , hcat [entryShow $ lens getY setY `lensMap` s, label $ return "y"]+        , hcat [entryShow $ lens getXY setXY `lensMap` s, label $ return "x + y"]+        ]++++++