packages feed

lgtk 0.5.3 → 0.5.4

raw patch · 16 files changed

+449/−184 lines, 16 filesdep +SVGFontsdep +diagrams-cairodep +diagrams-libdep −data-lens

Dependencies added: SVGFonts, diagrams-cairo, diagrams-lib, groups, lens, monad-control, transformers-base

Dependencies removed: data-lens

Files

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