lgtk (empty) → 0.1
raw patch · 17 files changed
+1296/−0 lines, 17 filesdep +basedep +containersdep +control-monad-freesetup-changed
Dependencies added: base, containers, control-monad-free, data-lens, directory, gtk, lgtk, mtl
Files
- LICENSE +31/−0
- Setup.hs +2/−0
- lgtk.cabal +81/−0
- main/Main.hs +27/−0
- src/Control/MLens/ExtRef.hs +70/−0
- src/Control/MLens/ExtRef/Pure.hs +111/−0
- src/Control/MLens/ExtRef/Pure/Test.hs +112/−0
- src/Control/MLens/NewRef.hs +66/−0
- src/Data/MLens.hs +173/−0
- src/Data/MLens/Ref.hs +84/−0
- src/GUI/MLens/Gtk.hs +60/−0
- src/GUI/MLens/Gtk/ADTEditor.hs +62/−0
- src/GUI/MLens/Gtk/Demos/IntListEditor.hs +86/−0
- src/GUI/MLens/Gtk/Demos/TEditor.hs +69/−0
- src/GUI/MLens/Gtk/Demos/Tri.hs +41/−0
- src/GUI/MLens/Gtk/IO.hs +189/−0
- src/GUI/MLens/Gtk/Interface.hs +32/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Péter Diviánszky 2013++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Péter Diviánszky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lgtk.cabal view
@@ -0,0 +1,81 @@+name: lgtk+version: 0.1+category: GUI+synopsis: lens-based GUI with Gtk backend+description:+ Try the demo executable lgtkdemo and read the source.+ .+ Key ingredients:+ .+ * monadic lenses+ .+ * expandable state+ .+ * lens-based GUI+stability: alpha+license: BSD3+license-file: LICENSE+author: Péter Diviánszky+maintainer: divipp@gmail.com+cabal-version: >= 1.8+build-type: Simple+++library++ hs-source-dirs:+ src+ build-depends:+ base < 5+ , containers+ , directory++ , mtl+ , control-monad-free+ -- Control.Category.Product is used only+ , data-lens++ , gtk+ exposed-modules:+ Data.MLens+ Data.MLens.Ref++ Control.MLens.NewRef+ Control.MLens.ExtRef+ Control.MLens.ExtRef.Pure+ Control.MLens.ExtRef.Pure.Test++ GUI.MLens.Gtk.Interface+ GUI.MLens.Gtk.IO+ GUI.MLens.Gtk+ GUI.MLens.Gtk.ADTEditor++ GUI.MLens.Gtk.Demos.Tri+ GUI.MLens.Gtk.Demos.IntListEditor+ GUI.MLens.Gtk.Demos.TEditor+ ghc-options: + -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing + -fno-warn-missing-signatures + -fno-warn-orphans+ -fno-warn-type-defaults++executable lgtkdemo++ build-depends:+ base < 5+ , mtl+ , lgtk+ main-is:+ Main.hs+ hs-source-dirs:+ main+ ghc-options: + -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing + -fno-warn-missing-signatures + -fno-warn-orphans+ -fno-warn-type-defaults+
+ main/Main.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE RankNTypes #-}+import Control.Monad+import Control.Monad.Trans+import Prelude hiding ((.), id)++import Control.MLens.ExtRef.Pure+import GUI.MLens.Gtk.IO+import GUI.MLens.Gtk++import GUI.MLens.Gtk.Demos.Tri+import GUI.MLens.Gtk.Demos.IntListEditor+import GUI.MLens.Gtk.Demos.TEditor++realize :: (forall i . I (Ext i IO)) -> IO ()+realize e = runExt_ mapI e >>= runI++main :: IO ()+main = realize $ 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+ ]+
+ src/Control/MLens/ExtRef.hs view
@@ -0,0 +1,70 @@+{-# 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 @k@ is a pure lens, and++@s <- extRef r k a0@.++The following laws should hold:++ * @s@ is a pure reference.++ * @(k . s)@ behaves exactly as @r@.++ * The initial value of @s@ is the result of @(readRef r >>= setL k a0)@.++Moreover, @(extRef r k a0)@ should not change the value of @r@.++The following two operations should be identical:++@newRew x@++@extRef unitLens unitLens x@++For examples, see "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++
+ src/Control/MLens/ExtRef/Pure.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{- |+Pure reference implementation for the @ExtRef@ interface.++The implementation use @unsafeCoerce@ internally, but its effect cannot escape.+-}+module Control.MLens.ExtRef.Pure+ ( Ext, runExt, runExt_+ ) where++import Control.Monad.State+import Control.Category+import Control.Category.Product+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 *** toList $ splitAt (length x) y++++newtype Ext i m a = Ext { unExt :: StateT (ST m) m a }+ deriving (Functor, Monad)++instance MonadTrans (Ext i) where+ lift = Ext . lift++extRef_ :: Monad m => MLens (Ext i m) a 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 b = unExt $ getL r2 b >>= flip (setL r1) b+ g b = unExt $ getL r1 b >>= 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_ . (. unitLens)++-- | 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+
+ src/Control/MLens/ExtRef/Pure/Test.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE RankNTypes #-}+-- | Tests for the reference implementation of the @ExtRef@ interface.+module Control.MLens.ExtRef.Pure.Test+ ( -- * Basic test environment+ Test, (==>), runTest+ -- * Test suit + , tests+ ) where++import Control.Monad.Writer+import Control.Category+import Prelude hiding ((.), id)++import Data.MLens+import Data.MLens.Ref+import Control.MLens.ExtRef+import Control.MLens.ExtRef.Pure++-----------------------------------------------------------------++-- | Tests use a writer monad to tell errors.+type Test i = Ext i (Writer [String])++-- | This operator checks the current value of a given reference.+(==>) :: (Eq a, Show a) => Ref (Test i) a -> a -> Test i ()+r ==> v = readRef r >>= \rv -> when (rv /= v) $ lift . tell . return $ "runTest failed: " ++ show rv ++ " /= " ++ show v++infix 0 ==>++-- | Test running results the list of error messages given by @(==>)@.+runTest :: (forall i . Test i a) -> [String]+runTest = execWriter . runExt ++--------------------++{- | +@tests@ contains error messages; it should be emtpy.++Look inside the sources for the tests.+-}+tests :: [String] +tests = newRefTest+ ++ writeRefTest+ ++ writeRefsTest+ ++ extRefTest+ ++ joinTest+ ++ joinTest2+ 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+++
+ src/Control/MLens/NewRef.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RankNTypes #-}+module Control.MLens.NewRef+ ( -- * Monads with reference creation+ NewRef (newRef)++ -- * Memo operators+ , memoMLens++ -- * Auxiliary functions+ , memoRead, memoWrite+ ) where++import Data.IORef+import Control.Monad+import Prelude hiding ((.), id)++import Data.MLens+import Data.MLens.Ref++class (Monad m) => NewRef m where+ newRef :: a -> m (Ref m a)++instance NewRef IO where+ newRef x = do+ r <- newIORef x+ return $ MLens $ \() -> do+ x <- readIORef r+ return (x, writeIORef r)+++-- | 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+++
+ src/Data/MLens.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE RankNTypes #-}+module Data.MLens+ ( -- * Monadic lenses data type+ MLens (MLens)++ -- * Side-effect free lenses+ , Lens+ , fromLens, toLens++ -- * Lens construction+ , 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 Control.Category.Product+import Control.Monad+import Control.Monad.Identity+import Data.Maybe+import Prelude hiding ((.), id)++{-|+Monadic lenses.++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).++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:++ * @getL@ has no side effect, i.e. @(getL k a >> return ())@ can be replaced by @(return ())@++TODO: List laws, document which laws hold for each lenses.+-}+data MLens m a b+ = MLens (a -> m (b, b -> m a))++{-|+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 (MLens f) = MLens $ \x -> do+ let (a, b) = runIdentity $ f x+ return (a, \y -> return $ runIdentity $ b y)++toLens :: (forall m . Monad m => MLens m a b) -> Lens a b+toLens k = k++lens :: Monad m => (a -> b) -> (b -> a -> a) -> MLens m a b+lens get set = MLens $ \a -> return (get a, return . flip set a)++getL :: Monad m => MLens m a b -> a -> m b+getL (MLens f) a = f a >>= return . fst++setL :: Monad m => MLens m a b -> b -> a -> m a+setL (MLens f) b a = f a >>= ($ b) . snd++modL :: Monad m => MLens m b a -> (a -> a) -> b -> m b+modL (MLens g) f b = do+ (x, h) <- g 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)++instance Monad m => Tensor (MLens m) where+ MLens r1 *** MLens r2 = MLens $ \(a1, a2) -> do+ (g1, s1) <- r1 a1+ (g2, s2) <- r2 a2+ return+ ( (g1, g2)+ , uncurry (liftM2 (,)) . (s1 *** s2)+ )++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 -> do+ MLens q <- r x+ q x++-- | 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 = MLens $ \(a,b) -> return (a, \a' -> return (a', b))++sndLens :: Monad m => MLens m (a,b) b+sndLens = MLens $ \(a,b) -> return (b, \b' -> return (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 = MLens $ \a ->+ return ((a, a), \(a1, a2) -> return $ 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+++++
+ src/Data/MLens/Ref.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE RankNTypes #-}+module Data.MLens.Ref+ ( -- * Data type for reference lenses+ Ref++ -- * Reference operations+ , readRef, writeRef, modRef++ -- * Some @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++{- |+Note that references lenses can be composed with lenses.+For example, if++@r :: Ref m (a,b)@++then++@fstLens . r :: Ref m a@++Reference laws for pure references:++ * @(readRef r)@ has no side effect.+ * @(readRef r >>= writeRef r)@ has no side effect.+ * @(writeRef r a >> readRef r)@ returns @a@.+ * @(writeRef r a >> writeRef r a)@ has the same effect as @(writeRef r a)@.+-}+type Ref m a = MLens m () a++readRef :: Monad m => MLens m () a -> m a+readRef k = getL k ()++writeRef :: Monad m => Ref m a -> a -> m ()+writeRef r a = setL r a ()++modRef :: Monad m => Ref m a -> (a -> a) -> m ()+k `modRef` f = modL k f ()++-- | 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 $ \() -> do+ b <- doesFileExist f+ if b then do+ xs <- readFile f+ length xs `seq` return (Just xs, wr)+ else return (Nothing, wr)+ where wr = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)++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+++
+ src/GUI/MLens/Gtk.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}++module GUI.MLens.Gtk -- --> GUI.MLens.Gtk.Interface+ ( module Control.Category+ , module Control.Category.Product+ , module Data.MLens+ , module Data.MLens.Ref+ , module Control.MLens.ExtRef+ , module GUI.MLens.Gtk.Interface++ -- * Composed+ , vcat, hcat+ , smartButton++ -- * Auxiliary functions+ , mapI+ , toFree+ ) where++import Control.Category+import Control.Category.Product+import Control.Monad.Free+import Prelude hiding ((.), id)++import Data.MLens+import Data.MLens.Ref+import Control.MLens.ExtRef+import GUI.MLens.Gtk.Interface++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) -> MLens 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)+++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++
+ src/GUI/MLens/Gtk/ADTEditor.hs view
@@ -0,0 +1,62 @@+{-# 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++
+ src/GUI/MLens/Gtk/Demos/IntListEditor.hs view
@@ -0,0 +1,86 @@+-- | An integer list editor+module GUI.MLens.Gtk.Demos.IntListEditor where++import GUI.MLens.Gtk++import Control.Monad+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) *** 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 []+++
+ src/GUI/MLens/Gtk/Demos/TEditor.hs view
@@ -0,0 +1,69 @@+--{-# LANGUAGE ExistentialQuantification #-}+--{-# LANGUAGE MultiParamTypeClasses #-}+--{-# LANGUAGE FlexibleInstances #-}+{-# 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]+ ]++
+ src/GUI/MLens/Gtk/Demos/Tri.hs view
@@ -0,0 +1,41 @@+{- |+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"]+ ]++++++
+ src/GUI/MLens/Gtk/IO.hs view
@@ -0,0 +1,189 @@+{-# 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 Data.MLens.Ref+import Control.MLens.NewRef+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 = (>>)++
+ src/GUI/MLens/Gtk/Interface.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE ExistentialQuantification #-}+-- | Lens-based Gtk interface+module GUI.MLens.Gtk.Interface+ ( I (..)+ , ListLayout (..)+ ) where++import Control.Monad.Free++import Data.MLens.Ref++-- | 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+