lgtk 0.1.0.2 → 0.2

raw patch · 10 files changed

+222/−128 lines, 10 filesdep −data-lensPVP ok

version bump matches the API change (PVP)

Dependencies removed: data-lens

API changes (from Hackage documentation)

Files

• lgtk.cabal +2/−3
• main/Main.hs +14/−6
• src/Control/MLens/ExtRef/Pure.hs +4/−3
• src/Control/MLens/ExtRef/Pure/Test.hs +7/−100
• src/Control/MLens/ExtRef/Test.hs +127/−0
• src/Control/MLens/NewRef.hs +10/−1
• src/Data/MLens.hs +25/−5
• src/Data/MLens/Ref.hs +13/−5
• src/GUI/MLens/Gtk.hs +18/−4
• src/GUI/MLens/Gtk/Demos/IntListEditor.hs +2/−1

@@ -1,5 +1,5 @@ name:               lgtk-version:            0.1.0.2+version:            0.2 category:           GUI synopsis:           lens-based GUI with Gtk backend description:@@ -26,8 +26,6 @@                    , mtl                   , control-monad-free-                  -- Control.Category.Product is used only-                  , data-lens                    , gtk   exposed-modules:@@ -36,6 +34,7 @@                      Control.MLens.NewRef                     Control.MLens.ExtRef+                    Control.MLens.ExtRef.Test                     Control.MLens.ExtRef.Pure                     Control.MLens.ExtRef.Pure.Test 

@@ -3,19 +3,20 @@ 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 +{- |+We use @unsafeRunI@ only because we read from an 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 = realize $ Notebook+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"@@ -24,4 +25,11 @@     , (,) "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+    ]+-}

@@ -11,8 +11,9 @@     ) where  import Control.Monad.State+import Control.Monad.Writer import Control.Category-import Control.Category.Product+import qualified Control.Arrow as Arrow import Data.Sequence import Data.Foldable (toList) import Prelude hiding ((.), id, splitAt, length)@@ -59,12 +60,12 @@      ST x ||> c = ST (x |> c) -    limit (ST x) (ST y) = ST *** toList $ splitAt (length x) y+    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)+    deriving (Functor, Monad, MonadWriter w)  instance MonadTrans (Ext i) where     lift = Ext . lift

@@ -1,112 +1,19 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Tests for the reference implementation of the @ExtRef@ interface. module Control.MLens.ExtRef.Pure.Test-    ( -- * Basic test environment-      Test, (==>), runTest-    -- * Test suit -    , tests+    ( -- * 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.Test 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-+newtype E i a = E { unE :: Ext i (Writer [String]) a } deriving (Monad, MonadWriter [String], NewRef, ExtRef) +tests :: [String]+tests = mkTests (\t -> execWriter $ runExt $ unE t) 

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

@@ -12,14 +12,21 @@  import Data.IORef import Control.Monad-import Prelude hiding ((.), id)+import Control.Monad.Writer+import Prelude -- hiding ((.), id)  import Data.MLens import Data.MLens.Ref +{- |+Laws for @NewRef@:++ *  Any reference created by @newRef@ should satisfy the reference laws given in "Data.MLens.Ref".+-} class (Monad m) => NewRef m where     newRef :: a -> m (Ref m a) +-- | 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@@ -27,6 +34,8 @@             x <- readIORef r             return (x, writeIORef r) +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)

@@ -14,6 +14,7 @@     , getL, setL, modL      -- * Lens transformations+    , (***)     , mapMLens     , joinML, joinLens @@ -35,7 +36,7 @@  import Data.Monoid import Control.Category-import Control.Category.Product+import qualified Control.Arrow as Arrow import Control.Monad import Control.Monad.Identity import Data.Maybe@@ -61,7 +62,7 @@  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 ())@+ *  get-no-effect: @(getL k a >> return ())@ === @(return ())@  TODO: List laws, document which laws hold for each lenses. -}@@ -74,6 +75,16 @@ The following representations would be also good for @(Lens a b)@:   *  @forall m . Monad m => MLens m a b@++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. -} type Lens a b     = MLens Identity a b@@ -107,14 +118,23 @@         (g1, s1) <- r1 g2         return (g1, s1 >=> s2) -instance Monad m => Tensor (MLens m) where-    MLens r1 *** MLens r2 = MLens $ \(a1, a2) -> do+-- | 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 *** s2)+            , 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

@@ -6,7 +6,7 @@     -- * Reference operations     , readRef, writeRef, modRef -    -- * Some @IO@ referenceses+    -- * Some impure @IO@ referenceses     , fileRef, fileRef_     , logConsoleLens @@ -33,10 +33,18 @@  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)@.+ *  @(readRef r)@ has no side effect++ *  @(readRef r >>= writeRef r)@ === @(return ())@++ *  @(writeRef r a >> readRef r)@ === @(return a)@++ *  @(writeRef r a >> writeRef r a')@ === @(writeRef r a')@++ *  Reference laws need not be preserved by composition, but they should be preserved if a+    pure lens is composed from the left.++These first four laws are equivalent to the get-no-effect, set-get, get-set and set-set laws for monadic lenses. -} type Ref m a = MLens m () a 

@@ -1,14 +1,17 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}--module GUI.MLens.Gtk -- --> GUI.MLens.Gtk.Interface+-- | The main LGtk interface, ideally users should import only this module.+module GUI.MLens.Gtk     ( module Control.Category-    , module Control.Category.Product     , module Data.MLens     , module Data.MLens.Ref     , module Control.MLens.ExtRef     , module GUI.MLens.Gtk.Interface +    -- * Running (rendering) and interface description+    , runI+    , unsafeRunI+     -- * Composed     , vcat, hcat     , smartButton@@ -19,7 +22,6 @@     ) where  import Control.Category-import Control.Category.Product import Control.Monad.Free import Prelude hiding ((.), id) @@ -27,6 +29,8 @@ import Data.MLens.Ref import Control.MLens.ExtRef import GUI.MLens.Gtk.Interface+import Control.MLens.ExtRef.Pure+import qualified GUI.MLens.Gtk.IO as Gtk  vcat :: [I m] -> I m vcat = List Vertical@@ -40,6 +44,16 @@ 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 (render) and interface description+runI :: (forall m . (Functor m, ExtRef m) => I m) -> IO ()+runI e = runExt_ mapI e >>= Gtk.runI++-- | Run (render) and 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

@@ -4,6 +4,7 @@ import GUI.MLens.Gtk  import Control.Monad+import qualified Control.Arrow as Arrow import Data.List import Data.Function (on) import Prelude hiding ((.), id)@@ -62,7 +63,7 @@         , 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])+        (uncurry zip . ((if r then enumFrom else repeat) Arrow.*** repeat)) (head $ reverse xs ++ [def])      def = (0, True)     maxi = 15