lgtk 0.5.4.1 → 0.6
raw patch · 12 files changed
+405/−631 lines, 12 filesdep +operationaldep −monad-controldep −transformers-base
Dependencies added: operational
Dependencies removed: monad-control, transformers-base
Files
- lgtk.cabal +2/−10
- src/Control/Monad/EffRef.hs +132/−52
- src/Control/Monad/ExtRef.hs +52/−86
- src/Control/Monad/ExtRef/Pure.hs +72/−66
- src/Control/Monad/ExtRef/Test.hs +4/−3
- src/Control/Monad/Register.hs +0/−35
- src/Control/Monad/Register/Basic.hs +0/−95
- src/Control/Monad/Restricted.hs +10/−132
- src/GUI/Gtk/Structures.hs +18/−31
- src/GUI/Gtk/Structures/IO.hs +82/−50
- src/LGtk.hs +32/−70
- src/LGtk/Demos/IntListEditor.hs +1/−1
lgtk.cabal view
@@ -1,5 +1,5 @@ name: lgtk-version: 0.5.4.1+version: 0.6 category: GUI synopsis: lens-based API for Gtk description:@@ -31,9 +31,8 @@ , fsnotify , transformers- , transformers-base , mtl- , monad-control+ , operational , gtk @@ -54,10 +53,6 @@ LGtk.Demos.Tri LGtk.Demos.IntListEditor LGtk.Demos.TEditor---- X--- OT2--- Demo other-modules: Data.Lens.Common @@ -66,9 +61,6 @@ Control.Monad.ExtRef Control.Monad.ExtRef.Pure Control.Monad.ExtRef.Test-- Control.Monad.Register- Control.Monad.Register.Basic Control.Monad.EffRef
src/Control/Monad/EffRef.hs view
@@ -3,34 +3,39 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-}-module Control.Monad.EffRef- ( EffRef (..)- , SafeIO (..)- , EffIORef (..)- , asyncWrite- , putStrLn_- , forkIOs- ) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Control.Monad.EffRef where +import Control.Applicative import Control.Concurrent import Control.Exception (evaluate) import Control.Monad-import Control.Monad.Base-import Control.Monad.Trans.Control+import Control.Monad.RWS+import Control.Monad.Writer++import Control.Monad.State 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 Control.Monad.Operational import Control.Monad.Restricted-import Control.Monad.Register import Control.Monad.ExtRef+import Control.Monad.ExtRef.Pure -- | Monad for dynamic actions class ExtRef m => EffRef m where + type CallbackM m :: * -> *++ type EffectM m :: * -> *+ liftEffectM' :: Morph (EffectM m) m {- |@@ -65,24 +70,90 @@ -} 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 ())+ toReceive :: Eq a => (a -> WriteRef m ()) -> (Command -> EffectM m ()) -> m (a -> CallbackM m ()) - rEffect :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()+data Command = Kill | Block | Unblock deriving (Eq, Ord, Show) --- | 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+rEffect :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()+rEffect init r f = onChange init r $ return . liftEffectM' . f - liftEffectM' = liftEffectM - onChange init = toSend_ init . liftReadRef+type SyntEffRef n m x = Program (EffRefI n m x)+data EffRefI n m x a where+ SyntLiftEffect :: m a -> EffRefI n m x a+ SyntLiftExtRef :: SyntExtRef x a -> EffRefI n m x a+ SyntOnChange :: Eq a => Bool -> SyntRefReader x a -> (a -> SyntEffRef n m x (SyntEffRef n m x ())) -> EffRefI n m x ()+ SyntReceive :: Eq a => (a -> SyntRefState x ()) -> (Command -> m ()) -> EffRefI n m x (a -> n ()) - toReceive fm = toReceive_ (liftWriteRef . fm)+instance ExtRef (SyntEffRef n m x) where+ type Ref (SyntEffRef n m x) = SyntRef x+ liftWriteRef w = singleton $ SyntLiftExtRef $ liftWriteRef w+ extRef r l a = singleton $ SyntLiftExtRef $ extRef r l a+ newRef a = singleton $ SyntLiftExtRef $ newRef a - rEffect init r f = onChange init r $ return . liftEffectM' . f+liftEffectM = singleton . SyntLiftEffect +instance EffRef (SyntEffRef n m x) where+ type EffectM (SyntEffRef n m x) = m+ type CallbackM (SyntEffRef n m x) = n+ liftEffectM' = singleton . SyntLiftEffect+ onChange b r f = singleton $ SyntOnChange b r f+ toReceive f g = singleton $ SyntReceive f g+++type CO m = WriterT (MonadMonoid m, Command -> MonadMonoid m) m++evalRegister' :: (NewRef m) => (StateT LSt m () -> m ()) -> SyntEffRef m (StateT LSt m) (Lens_ LSt) a -> CO (StateT LSt m) a+evalRegister' ff = eval . view+ where+ eval (Return x) = return x+ eval (SyntLiftEffect m :>>= k) = lift m >>= evalRegister' ff . k+ eval (SyntLiftExtRef m :>>= k) = lift (runExtRef m) >>= evalRegister' ff . k+ eval (SyntReceive f g :>>= k) = tell (t2 g) >> evalRegister' ff (k $ ff . runExtRef . liftWriteRef . f)+ eval (SyntOnChange b r f :>>= k) = toSend__ b (runExtRef $ liftReadRef r) (liftM (evalRegister' ff) . evalRegister' ff . f) >>= evalRegister' ff . k++newRef'' x = liftM (\r -> MorphD $ \m -> StateT $ \s -> runMorphD r $ mapStateT (\k -> runStateT k s >>= \((x, w), s) -> return ((x, s), w)) m) $ newRef' x++--toSend__ :: (Eq b, NewRef m) => Bool -> m b -> (b -> Register' m (Register' m ())) -> Register' m ()+toSend__ init rb fb = do+ b <- lift rb+ v <- case init of+ False -> return $ Left b+ True -> lift $ do+ (c, (s1, ureg1)) <- runWriterT (fb b)+ (s2, ureg2) <- execWriterT c+ runMonadMonoid $ s1 `mappend` s2+ return $ Right [(b, (c, s1, s2, ureg1, ureg2))]+ memoref <- lift $ lift $ newRef'' v+ -- memo table, first item is the newest+ tell $ t1 $ do+ b <- rb+ join $ runMorphD memoref $ StateT $ \memo -> case memo of+ Left b' | b' == b -> return (return (), memo)+ Right ((b', (_, s1, s2, _, _)): _) | b' == b ->+ return (runMonadMonoid $ s1 `mappend` s2, memo)+ _ -> 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))+ _ -> runWriterT (fb b)+ (s2, ureg2) <- execWriterT c+ let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo+ return (runMonadMonoid $ s1 `mappend` s2, memo')++t1 m = (MonadMonoid m, mempty)+t2 m = (mempty, MonadMonoid . m)++ -- | 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. @@ -92,7 +163,6 @@ Although @(asyncWrite 0)@ is safe, code using it has a bad small. -} asyncWrite_ :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()- asyncWrite' :: Int -> WriteRef m () -> m () {- | @(fileRef path)@ returns a reference which holds the actual contents@@ -110,8 +180,6 @@ -} 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,@@ -119,7 +187,8 @@ -} getLine_ :: (String -> WriteRef m ()) -> m () - registerIO :: Eq a => (a -> WriteRef m ()) -> ((a -> IO ()) -> IO (Command -> IO ())) -> m ()+ -- | Write a string to the standard output device.+ putStr_ :: EffIORef m => String -> m () -- | @putStrLn_@ === @putStr_ . (++ "\n")@ putStrLn_ :: EffIORef m => String -> m ()@@ -128,22 +197,20 @@ 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), MonadBaseControl IO (EffectM m), SafeIO (ReadRef m), SafeIO m) => EffIORef (IdentityT m) where+asyncWrite' :: EffIORef m => Int -> WriteRef m () -> m ()+asyncWrite' t r = asyncWrite_ t (const r) () - registerIO r fm = do- _ <- toReceive r $ \x -> unliftIO $ \u -> liftM (fmap liftBase) $ fm $ void . u . x- return ()+type SyntEffIORef m x = SyntEffRef m (StateT LSt m) x - asyncWrite_ t r a- = registerIO r $ \re -> forkIOs [ threadDelay t, re a ]- asyncWrite' t r = asyncWrite_ t (const r) ()+instance SafeIO (SyntRefReader x) where+instance SafeIO (SyntEffIORef m x) where - putStr_ = liftIO' . putStr+instance EffIORef (SyntEffIORef IO x) where - getLine_ w = registerIO w $ \re -> do- _ <- forkIO $ getLine >>= re- return $ const $ return () -- TODO+ asyncWrite_ t r a = do+ (u, f) <- liftIO' forkIOs'+ x <- toReceive r $ liftIO . u+ liftIO' $ f [ threadDelay t, x a ] fileRef f = do ms <- liftIO' r@@ -172,8 +239,12 @@ watchDir man (directory cf') filt act liftIO' startm- registerIO (writeRef ref) $ \re -> forkForever $ takeMVar v >> r >>= re- rEffect False (readRef ref) $ \x -> liftBase $ do++ (u, ff) <- liftIO' forkIOs'+ re <- toReceive (writeRef ref) $ liftIO . u+ liftIO' $ ff $ repeat $ takeMVar v >> r >>= re++ rEffect False (readRef ref) $ \x -> liftIO $ do join $ takeMVar vman _ <- tryTakeMVar v putStrLn " write"@@ -192,27 +263,36 @@ w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f) + getLine_ w = do+ (u, f) <- liftIO' forkIOs'+ x <- toReceive w $ liftIO . u+ liftIO' $ f [ getLine >>= x ] -- TODO+ putStr_ s = liftIO' $ putStr s ---liftIO' :: EffIORef_ m => IO a -> m a-liftIO' m = liftEffectM $ liftBase m+liftIO__ :: Monad m => m a -> SyntEffIORef m (Lens_ LSt) a+liftIO__ m = singleton $ SyntLiftEffect $ lift m -forkForever :: IO () -> IO (Command -> IO ())-forkForever = forkIOs . repeat+--liftIO' :: EffIORef m => IO a -> m a+liftIO' m = liftEffectM $ liftIO m -forkIOs :: [IO ()] -> IO (Command -> IO ())-forkIOs ios = do++--forkIOs' :: IO (Command -> IO (), [IO ()] -> IO ())+forkIOs' = do x <- newMVar ()- let g [] = return ()- g (i:is) = do- () <- takeMVar x- putMVar x ()- i- g is+ s <- newEmptyMVar+ let g = do+ readMVar x+ is <- takeMVar s+ case is of+ [] -> return ()+ (i:is) -> do+ putMVar s is+ i+ g f i Kill = killThread i f _ Block = takeMVar x f _ Unblock = putMVar x () - liftM f $ forkIO $ g ios--+ i <- forkIO g+ return (f i, putMVar s)
src/Control/Monad/ExtRef.hs view
@@ -2,74 +2,67 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-}-module Control.Monad.ExtRef- ( module Data.Lens.Common+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Control.Monad.ExtRef where - -- * Restricted monads- , HasReadPart (..)+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+--import Control.Monad.RWS+--import Control.Monad.Trans.Identity+--import Control.Monad.Operational+import Data.Lens.Common - -- * Reference class- , Reference (..)- , ReadRefMonad+-- | @m@ has a submonad @(RefStateReader m)@ which is isomorphic to 'Reader'.+class (Monad m, Monad (RefStateReader m)) => MonadRefState m where - -- * Ref construction class- , ExtRef (..)- , ReadRef- , WriteRef+ {- | Law: @(RefStateReader m)@ === @('Reader' x)@ for some @x@. - -- * Derived constructs- , modRef- , liftReadRef- , readRef'- , undoTr- , memoRead- , memoWrite+ Alternative laws which ensures this isomorphism (@r :: (RefStateReader m a)@ is arbitrary): - -- * References with equation- , EqReference (..)- , EqRef- , eqRef- , newEqRef- , toRef+ * @(r >> return ())@ === @return ()@ - -- * Auxiliary definitions- , Morph- , MorphD (..)--- , MonadIO' (..)- ) where+ * @liftM2 (,) r r@ === @liftM (\a -> (a, a)) r@ -import Control.Monad-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.RWS-import Control.Monad.Trans.Identity-import Data.Maybe-import Data.Lens.Common+ See also <http://stackoverflow.com/questions/16123588/what-is-this-special-functor-structure-called>+ -}+ type RefStateReader m :: * -> * -import Control.Monad.Restricted+ -- | @(RefStateReader m)@ is a submonad of @m@+ liftRefStateReader :: RefStateReader m a -> m a +-- | @RefStateReader (StateT s m) = Reader s@ +instance Monad m => MonadRefState (StateT s m) where+ type RefStateReader (StateT s m) = Reader s+ liftRefStateReader = gets . runReader++ {- | 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+class (MonadRefState (RefState r)) => Reference r where {- | @Refmonad r@ === @State s@ - Property derived from the 'HasReadPart' instance:+ Property derived from the 'MonadRefState' instance: - @ReadRefMonad r@ = @ReadPart (Refmonad r)@ === @Reader s@+ @RefReader r@ = @RefStateReader (Refmonad r)@ === @Reader s@ -}- type RefMonad r :: * -> *+ type RefState r :: * -> * {- | @readRef@ === @reader . getL@ - Properties derived from the 'HasReadPart' instance:+ Properties derived from the 'MonadRefState' instance: @(readRef r >> return ())@ === @return ()@ -}- readRef :: r a -> ReadRefMonad r a+ readRef :: r a -> RefReader r a {- | @writeRef r@ === @modify . setL r@ @@ -81,7 +74,7 @@ * @(writeRef r a >> writeRef r a')@ === @writeRef r a'@ -}- writeRef :: r a -> a -> RefMonad r ()+ writeRef :: r a -> a -> RefState r () {- | Apply a lens on a reference. @@ -95,20 +88,21 @@ @joinRef@ === @Lens . join . (runLens .) . runReader@ -}- joinRef :: ReadRefMonad r (r a) -> r a+ joinRef :: RefReader r (r a) -> r a -- | @unitRef@ === @lens (const ()) (const id)@ unitRef :: r () -type ReadRefMonad m = ReadPart (RefMonad m)+type RefReader m = RefStateReader (RefState m) 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 +-- | @modRef r f@ === @liftRefStateReader (readRef r) >>= writeRef r . f@+modRef :: Reference r => r a -> (a -> a) -> RefState r ()+r `modRef` f = liftRefStateReader (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.@@ -122,7 +116,7 @@ type Ref m :: * -> * -- | @'WriteRef' m@ is a submonad of @m@.- liftWriteRef :: Morph (WriteRef m) m+ liftWriteRef :: WriteRef m a -> m a {- | Reference creation by extending the state of an existing reference. @@ -151,17 +145,17 @@ newRef = extRef unitRef $ lens (const ()) (flip $ const id) -type WriteRef m = RefMonad (Ref m)+type WriteRef m = RefState (Ref m) -type ReadRef m = ReadRefMonad (Ref m)+type ReadRef m = RefReader (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+liftReadRef :: ExtRef m => ReadRef m a -> m a+liftReadRef = liftWriteRef . liftRefStateReader {- | @readRef@ lifted to the reference creation class. @@ -212,35 +206,8 @@ 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 =>@@ -281,20 +248,20 @@ hasEffect :: r a -> (a -> a)- -> ReadRefMonad r Bool+ -> RefReader r Bool 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@ === @RefReader r (exist b . Eq b => (Lens' b a, r b))@ As a reference, @(m :: EqRef r a)@ behaves as @joinRef $ liftM (uncurry lensMap) m@ -}-newtype EqRef r a = EqRef { runEqRef :: ReadRefMonad r (EqRef_ r a) }+newtype EqRef r a = EqRef { runEqRef :: RefReader r (EqRef_ r a) } {- | @EqRef@ construction. -}@@ -317,7 +284,7 @@ instance Reference r => Reference (EqRef r) where - type (RefMonad (EqRef r)) = RefMonad r+ type (RefState (EqRef r)) = RefState r readRef = readRef . toRef @@ -328,5 +295,4 @@ joinRef = EqRef . join . liftM runEqRef unitRef = eqRef unitRef-
src/Control/Monad/ExtRef/Pure.hs view
@@ -5,77 +5,110 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-} {- | 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+module Control.Monad.ExtRef.Pure where -import Control.Monad.Base-import Control.Monad.Trans.Control+--import Control.Monad.Base+--import Control.Monad.Trans.Control import Control.Monad.State import Control.Monad.Reader import Control.Monad.Identity-import Control.Category+import Control.Monad.Operational import Control.Arrow ((***))-import Data.Sequence+import Data.Sequence hiding (singleton) import Data.Lens.Common import Data.Foldable (toList)-import Prelude hiding ((.), id, splitAt, length)+import Prelude hiding (splitAt, length) import Unsafe.Coerce-import System.IO.Unsafe -import Control.Monad.Restricted import Control.Monad.ExtRef -newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b}+----------------- synthetic data types and instances -instance Reference (Lens_ a) where+type SyntRefReader x = Program (RefReaderI x)+data RefReaderI x a where+ SyntReadRef :: SyntRef x a -> RefReaderI x a - type RefMonad (Lens_ a) = State a+type SyntRefState x = Program (RefStateI x)+data RefStateI x a where+ SyntLiftRefReader :: SyntRefReader x a -> RefStateI x a+ SyntWriteRef :: SyntRef x a -> a -> RefStateI x () - readRef (Lens_ r) = reader $ getL r+instance MonadRefState (SyntRefState x) where+ type RefStateReader (SyntRefState x) = SyntRefReader x+ liftRefStateReader = singleton . SyntLiftRefReader - writeRef (Lens_ r) = modify . setL r+data SyntRef x a where+ SyntUnitRef :: SyntRef x ()+ SyntLensMap :: Lens' a b -> SyntRef x a -> SyntRef x b+ SyntJoinRef :: SyntRefReader x (SyntRef x a) -> SyntRef x a+ SyntCreatedRef :: x a -> SyntRef x a - lensMap l (Lens_ r) = Lens_ $ r . l+instance Reference (SyntRef x) where+ type RefState (SyntRef x) = SyntRefState x+ readRef = singleton . SyntReadRef+ writeRef r = singleton . SyntWriteRef r+ lensMap = SyntLensMap+ joinRef = SyntJoinRef+ unitRef = SyntUnitRef - unitRef = Lens_ $ lens (const ()) (flip $ const id)+type SyntExtRef x = Program (ExtRefI x)+data ExtRefI x a where+ SyntLiftRefState :: SyntRefState x a -> ExtRefI x a+ SyntExtRef :: SyntRef x b -> Lens' a b -> a -> ExtRefI x (SyntRef x a)+-- SyntNewRef :: a -> ExtRefI x (SyntRef x a) - joinRef m = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader m+instance ExtRef (SyntExtRef x) where+ type Ref (SyntExtRef x) = SyntRef x+ liftWriteRef w = singleton $ SyntLiftRefState w+ extRef r l = singleton . SyntExtRef r l+-- newRef = singleton . SyntNewRef -type LSt = Seq CC+---------------------- -initLSt :: LSt-initLSt = empty+newtype Lens_ a b = Lens_ {unLens_ :: Lens' a b} -data CC = forall a . CC (LSt -> a -> a) a+type LSt = Seq CC -ap_ :: LSt -> CC -> CC-ap_ x (CC f a) = CC f (f x a)+data CC = forall a . CC (LSt -> a -> a) a -unsafeData :: CC -> a-unsafeData (CC _ a) = unsafeCoerce a+initLSt :: LSt+initLSt = empty -instance Monad m => ExtRef (StateT LSt m) where+runSyntRefReader :: SyntRefReader (Lens_ x) a -> Reader x a+runSyntRefReader = interpretWithMonad eval where+ eval (SyntReadRef r) = reader $ getL $ unLens_ $ runSyntRef r - type Ref (StateT LSt m) = Lens_ LSt+runSyntRefState :: SyntRefState (Lens_ x) a -> State x a+runSyntRefState = interpretWithMonad eval where+ eval (SyntLiftRefReader r) = liftRefStateReader $ runSyntRefReader r+ eval (SyntWriteRef r a) = modify $ setL (unLens_ $ runSyntRef r) a - liftWriteRef = mapStateT (return . runIdentity)+runSyntRef :: SyntRef (Lens_ x) a -> Lens_ x a+runSyntRef SyntUnitRef = Lens_ $ lens (const ()) $ const . id+runSyntRef (SyntLensMap l r) = Lens_ $ (unLens_ $ runSyntRef r) . l+runSyntRef (SyntJoinRef m) = (\f -> Lens_ $ \g s -> unLens_ (f s) g s) $ runReader $ liftM runSyntRef $ runSyntRefReader m+runSyntRef (SyntCreatedRef l) = l - extRef (Lens_ r1) r2 a0 = state extend where+runExtRef :: Monad m => SyntExtRef (Lens_ LSt) a -> StateT LSt m a+runExtRef = interpretWithMonad eval where+ eval (SyntLiftRefState w) = mapStateT (return . runIdentity) $ runSyntRefState w+ eval (SyntExtRef r r2 a0) = state extend+ where+ r1 = runSyntRef r - rk = setL r1 . getL r2- kr = setL r2 . getL r1+ rk = setL (unLens_ r1) . getL r2+ kr = setL r2 . getL (unLens_ r1) - extend x0 = (Lens_ $ lens get set, x0 |> CC kr (kr x0 a0))+ extend x0 = (SyntCreatedRef $ Lens_ $ lens get set, x0 |> CC kr (kr x0 a0)) where limit = (id *** toList) . splitAt (length x0) @@ -84,38 +117,11 @@ set x a = 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----instance (MonadBaseControl IO m) => SafeIO m where---- | Advanced running of the @ExtRef@ monad.-runExtRef_- :: 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--+ ap_ :: LSt -> CC -> CC+ ap_ x (CC f a) = CC f (f x a) + unsafeData :: CC -> a+ unsafeData (CC _ a) = unsafeCoerce a +-- eval (SyntNewRef a) = newRef a
src/Control/Monad/ExtRef/Test.hs view
@@ -12,13 +12,14 @@ -- , testExtIORef ) where +import Control.Monad.State import Control.Monad.Writer-import Control.Monad.Identity import Control.Category import Control.Arrow ((***)) import Data.Maybe import Prelude hiding ((.), id) +import Data.Lens.Common import Control.Monad.ExtRef import qualified Control.Monad.ExtRef.Pure as Pure --import qualified Control.Monad.ExtRef.IORef as IORef@@ -27,7 +28,7 @@ -- | 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+testExtPure = mkTests $ \t -> flip evalState Pure.initLSt $ Pure.runExtRef $ execWriterT t {- -- | Consistency tests for the @IORef@-based implementation of @Ext@, should give an empty list of errors.@@ -250,7 +251,7 @@ undoTest3 = runTest $ do r <- newRef 3- (undo, redo) <- liftM (liftReadPart *** liftReadPart) $ undoTr (==) r+ (undo, redo) <- liftM (liftRefStateReader *** liftRefStateReader) $ undoTr (==) r r ==> 3 redo === False undo === False
− src/Control/Monad/Register.hs
@@ -1,35 +0,0 @@-{-# 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-
− src/Control/Monad/Register/Basic.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Control.Monad.Register.Basic- ( evalRegister- , evalRegisterBasic- ) where--import Control.Monad-import Control.Monad.State-import Control.Monad.RWS-import Data.List--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 $ StateT $ \memo -> case memo of- Left b' | b' == b -> return (return (), memo)- Right ((b', (_, s1, s2, _, _)): _) | b' == b ->- return (runMonadMonoid $ s1 `mappend` s2, memo)- _ -> 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 ()- let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo- return (runMonadMonoid $ s1 `mappend` s2, memo')--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---
src/Control/Monad/Restricted.hs view
@@ -1,35 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-module Control.Monad.Restricted- ( -- * Auxiliary definitions- Morph- , MorphD (..)- , Ext (..), lift', runExt- , HasReadPart (..)- , unliftIO, unliftIO'- , SafeIO (..)- , NewRef (..)- , MonadMonoid (..)- ) where+module Control.Monad.Restricted 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-import Control.Monad.RWS-import Control.Monad.Trans.Identity import qualified System.Environment as Env import System.IO.Error (catchIOError, isDoesNotExistError) @@ -44,77 +18,17 @@ -} newtype MorphD m n = MorphD { runMorphD :: Morph m n } --- | @m@ 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 :: 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, 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 :: (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------------------------type MonadIO' m = (MonadIO m, MonadBaseControl IO m)+------------------- -unliftIO' :: MonadBaseControl n m => ((m () -> n ()) -> m a) -> m a-unliftIO' f = liftBaseWith (\m -> m $ f $ void . m) >>= restoreM+class (Monad m) => NewRef m where+ newRef' :: a -> m (MorphD (StateT a m) m) -unliftIO :: MonadBaseControl n m => ((m () -> n ()) -> n a) -> m a-unliftIO f = liftBaseWith (\m -> f $ void . m)+instance NewRef IO where+ newRef' x = do+ vx <- liftIO $ newMVar x+ return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m+ where+ swap (a, b) = (b, a) ------------------- @@ -138,42 +52,6 @@ -- lookupEnv = Env.lookupEnv -- does not work with Haskell Platform 2013.2.0.0 lookupEnv v = catchIOError (liftM Just $ Env.getEnv v) $ \e -> if isDoesNotExistError e then return Nothing else ioError e---- | 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' :: a -> m (MorphD (StateT a m) m)--instance NewRef IO where- newRef' x = do- vx <- liftIO $ newMVar x- return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m- where- swap (a, b) = (b, a)--instance (MonadBase m m, NewRef m) => NewRef (Ext n m) where- newRef' = liftM (\m -> MorphD $ \k -> unlift $ runMorphD m . flip mapStateT k) . lift . newRef' -------------------
src/GUI/Gtk/Structures.hs view
@@ -2,55 +2,42 @@ {-# LANGUAGE RankNTypes #-} -- | Lens-based Gtk interface module GUI.Gtk.Structures- ( Send- , Receive- , SendReceive- , Widget (..)- , ListLayout (..)- , MouseEvent (..)- , ScrollDirection (..)- , MousePos (..)+ ( module GUI.Gtk.Structures+ , module Graphics.UI.Gtk , 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.Prelude (QDiagram, R2, Monoid) import Diagrams.Backend.Cairo (Cairo) import Graphics.UI.Gtk (ScrollDirection (..), KeyVal, Modifier, keyName, keyToChar) -import Control.Monad.Register (Command (..))+import Control.Monad.EffRef (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)+type Receive n m k a = (Command -> n ()) -> m (a -> k ())+type SendReceive n m k a = (Send n m a, Receive n m k a) +type Widget n m k = m (WidgetCore n m k)+ -- | Widget descriptions-data Widget n m+data WidgetCore n m k = 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 ()+ , action_ :: Receive n m k () } -- ^ 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- | 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)+ | Checkbox (SendReceive n m k Bool) -- ^ checkbox+ | Combobox [String] (SendReceive n m k Int) -- ^ combo box+ | Entry (SendReceive n m k String) -- ^ entry field+ | List ListLayout [Widget n m k] -- ^ group interfaces into row or column+ | Notebook' (Receive n m k Int) [(String, Widget n m k)] -- ^ actual tab index, tabs+ | forall b . Eq b => Cell ((b -> m (m ())) -> m ()) (forall a . (Widget n m k -> m a) -> b -> m (m a))+ | forall a b . (Eq b, Eq a, Monoid a) => Canvas Int Int Double (Receive n m k (MouseEvent a)) (Send n m b) (b -> Dia a)+ | Scale Double Double Double (SendReceive n m k Double) data ListLayout = Horizontal
src/GUI/Gtk/Structures/IO.hs view
@@ -4,18 +4,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RecursiveDo #-} module GUI.Gtk.Structures.IO ( runWidget- , gtkContext ) where import Control.Category import Control.Monad-import Control.Monad.Trans.Control+import Control.Monad.State 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)@@ -24,16 +22,40 @@ 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 Control.Monad.Restricted+import Control.Monad.ExtRef+import Control.Monad.ExtRef.Pure+import Control.Monad.EffRef import GUI.Gtk.Structures -import Diagrams.Prelude hiding (Widget)+import Diagrams.Prelude import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo.Internal ------------------------- +{- |+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 (EffectM m) m (CallbackM m)) -> IO ()+runWidget desc = gtkContext $ \postGUISync -> mdo+ postActionsRef <- newRef' $ return ()+ let addPostAction = runMorphD postActionsRef . modify . flip (>>)+ runPostActions = join $ runMorphD postActionsRef $ state $ \m -> (m, return ())+ actionChannel <- newChan+ ((widget, (act, _)), s) <- flip runStateT initLSt $ runWriterT $ evalRegister' (writeChan actionChannel) $+ runWidget_ id addPostAction postGUISync id id liftIO__ liftIO desc+ runPostActions+ _ <- forkIO $ void $ flip execStateT s $ forever $ do+ join $ lift $ readChan actionChannel+ runMonadMonoid act+ lift $ runPostActions+ return widget++ gtkContext :: (Morph IO IO -> IO SWidget) -> IO () gtkContext m = do _ <- unsafeInitGUIForThreadedRTS@@ -52,26 +74,35 @@ type SWidget = (IO (), Gtk.Widget) -- | Run an @IO@ parametrized interface description with Gtk backend-runWidget- :: forall n m . (MonadIO m, MonadIO n)- => (n () -> IO ())+runWidget_+ :: forall n m k o . (Monad m, Monad o)+ => (k () -> IO ()) -> (IO () -> IO ()) -> Morph IO IO- -> Widget n m- -> m SWidget-runWidget nio post' post = toWidget+ -> Morph m o+ -> Morph o m+ -> Morph IO o+ -> (IO () -> n ())+ -> Widget n m k+ -> o SWidget+runWidget_ nio post' post liftO liftOBack liftIO_ liftION = toWidget where- liftIO' :: MonadIO k => IO a -> k a- liftIO' = liftIO . post---- nio = undefined+ liftIO' :: IO a -> o a+ liftIO' = liftIO_ . post - -- 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 .)+ -- type Receive n m k a = (Command -> n ()) -> m (a -> k ())+ reg :: Receive n m k a -> ((a -> IO ()) -> IO (Command -> IO ())) -> o (Command -> IO ())+ reg s f = do+ rer <- liftIO_ newEmptyMVar+ u <- liftIO_ $ f $ \x -> do+ re <- readMVar rer+ nio $ re x+ re <- liftO $ s $ liftION . post . u+ liftIO_ $ putMVar rer re+ return u - ger :: (Command -> IO ()) -> Send n m a -> Send IO m a- ger hd s f = s $ \a -> liftIO' $ do+ ger :: (Command -> IO ()) -> Send n m a -> Send IO o a+ ger hd s f = liftO $ s $ \a -> liftION $ post $ do hd Block f a hd Unblock@@ -79,26 +110,27 @@ nhd :: Command -> IO () nhd = const $ return () - toWidget :: Widget n m -> m SWidget- toWidget i = case i of+ toWidget :: Widget n m k -> o SWidget+ toWidget m = liftO m >>= \i -> case i of - Action m -> m >>= toWidget+-- Action m -> liftO m >>= toWidget Label s -> do 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+ 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+ _ <- canvas `onSizeRequest` return (Requisition w h)+ _ <- containerAdd af canvas let dims = do win <- widgetGetDrawWindow canvas@@ -110,7 +142,7 @@ 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_+ _ <- swapMVar cur $ Just dia_ let dia = freeze $ clearValue dia_ (sc, w, h, wi, he) <- dims win <- widgetGetDrawWindow canvas@@ -127,25 +159,25 @@ 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+ _ <- reg me $ \re -> do+ _ <- on' canvas buttonPressEvent $ tryEvent $ do -- click <- eventClick p <- eventCoordinates >>= liftIO . compCoords liftIO $ re $ Click p- on' canvas buttonReleaseEvent $ tryEvent $ do+ _ <- on' canvas buttonReleaseEvent $ tryEvent $ do -- click <- eventClick p <- eventCoordinates >>= liftIO . compCoords liftIO $ re $ Release p- on' canvas enterNotifyEvent $ tryEvent $ do+ _ <- on' canvas enterNotifyEvent $ tryEvent $ do p <- eventCoordinates >>= liftIO . compCoords liftIO $ re $ MouseEnter p- on' canvas leaveNotifyEvent $ tryEvent $ do+ _ <- on' canvas leaveNotifyEvent $ tryEvent $ do p <- eventCoordinates >>= liftIO . compCoords liftIO $ re $ MouseLeave p- on' canvas motionNotifyEvent $ tryEvent $ do+ _ <- on' canvas motionNotifyEvent $ tryEvent $ do p <- eventCoordinates >>= liftIO . compCoords liftIO $ re $ MoveTo p- on' canvas scrollEvent $ tryEvent $ do+ _ <- on' canvas scrollEvent $ tryEvent $ do p <- eventCoordinates >>= liftIO . compCoords dir <- eventScrollDirection liftIO $ re $ ScrollTo dir p@@ -154,24 +186,24 @@ m <- eventModifier c <- eventKeyVal liftIO $ re $ KeyPress m c- _ <- liftIO $ on canvas exposeEvent $ tryEvent $ liftIO $ do+ _ <- liftIO_ $ on canvas exposeEvent $ tryEvent $ liftIO $ do d <- readMVar cur' case d of Just x -> putMVar v x _ -> return () - canvasDraw' <- liftIO $ do+ canvasDraw' <- liftIO_ $ do v2 <- newMVar False- forkIO $ do+ _ <- forkIO $ do threadDelay 200000 forever $ do threadDelay 10000 dia <- takeMVar v- swapMVar cur' $ Just dia- swapMVar v2 True+ _ <- swapMVar cur' $ Just dia+ _ <- swapMVar v2 True let d = diaFun dia post $ canvasDraw d- swapMVar v2 False+ _ <- swapMVar v2 False return () return $ \dia -> do b <- readMVar v2@@ -204,13 +236,13 @@ return' w Scale a b c (r, s) -> do w <- liftIO' $ hScaleNewWithRange a b c- liftIO' $ w `onSizeRequest` return (Requisition 200 40)+ _ <- 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' $ 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@@ -234,10 +266,10 @@ 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 + sh <- liftIO_ $ newMVar $ return ()+ liftO $ onCh $ \bv -> do+ mx <- f (liftOBack . toWidget) bv+ return $ mx >>= \(x, y) -> liftOBack $ liftIO' $ do _ <- swapMVar sh x containerForeach w $ if b then widgetHideAll else containerRemove w post' $ post $ do
src/LGtk.hs view
@@ -3,15 +3,15 @@ -- | Main LGtk interface. module LGtk (- -- * Monad morphisms- Morph- , HasReadPart (..)- -- * References- -- ** Basic operations++ -- ** Reference modifying monad+ MonadRefState (..)++ -- ** Reference operations , Reference- , RefMonad- , ReadRefMonad+ , RefState+ , RefReader , readRef , writeRef , lensMap@@ -102,22 +102,15 @@ ) where import Data.Maybe-import Control.Concurrent+import Data.Monoid import Control.Monad-import Control.Monad.Base-import Control.Monad.State-import Control.Monad.Trans.Identity 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 qualified GUI.Gtk.Structures.ThreePenny as TP-import Control.Monad.ExtRef.Pure import Control.Monad.Restricted @@ -129,8 +122,10 @@ @Widget@ should be abstract data type, 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+type Widget m = Gtk.Widget (EffectM m) m (CallbackM m) +--type SyntWidget = Widget (SyntEffIORef X)+ {- | Run a Gtk widget description. @@ -138,56 +133,23 @@ It leaves the event cycle when the window is closed. -} 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- Gtk.gtkContext $ \postGUISync -> do- widget <- runExtRef_ $ unliftIO' $ \unlift ->- evalRegister- (runIdentityT $ Gtk.runWidget unlift addPostAction postGUISync desc)- (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+runWidget = Gtk.runWidget - 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+vcat :: Monad m => [Widget m] -> Widget m+vcat = return . List Vertical -- | Horizontal composition of widgets.-hcat :: [Widget m] -> Widget m-hcat = List Horizontal+hcat :: Monad m => [Widget m] -> Widget m+hcat = return . List Horizontal -- | Empty widget.-empty :: Widget m+empty :: Monad m => Widget m empty = hcat [] -- | Dynamic label. label :: EffRef m => ReadRef m String -> Widget m-label = Label . rEffect True+label = return . Label . rEffect True -- | Low-level button with changeable background color. button__@@ -197,7 +159,7 @@ -> 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)+button__ r x c y = return $ Button (rEffect True r) (rEffect True x) (rEffect True c) (toReceive $ \() -> y) -- | Low-level button. button_@@ -206,19 +168,19 @@ -> 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_ r x y = return $ 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)+button r fm = button_ r (liftM isJust fm) (liftRefStateReader fm >>= maybe (return ()) id) smartButton- :: (EffRef m, EqReference r, RefMonad r ~ RefMonad (Ref m)) + :: (EffRef m, EqReference r, RefState r ~ RefState (Ref m)) => ReadRef m String -- ^ dynamic label of the button -> r 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.@@ -228,18 +190,18 @@ -- | Checkbox. checkbox :: EffRef m => Ref m Bool -> Widget m-checkbox r = Checkbox (rEffect True (readRef r), toReceive $ writeRef r)+checkbox r = return $ 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)+combobox ss r = return $ Combobox ss (rEffect True (readRef r), toReceive $ writeRef r) -- | Text entry.-entry :: (EffRef m, Reference r, RefMonad r ~ RefMonad (Ref m)) => r String -> Widget m-entry r = Entry (rEffect True (readRef r), toReceive $ writeRef r)+entry :: (EffRef m, Reference r, RefState r ~ RefState (Ref m)) => r String -> Widget m+entry r = return $ Entry (rEffect True (readRef r), toReceive $ writeRef r) -- | Text entry.-entryShow :: (EffRef m, Show a, Read a, Reference r, RefMonad r ~ RefMonad (Ref m)) => r a -> Widget m+entryShow :: (EffRef m, Show a, Read a, Reference r, RefState r ~ RefState (Ref m)) => r a -> Widget m entryShow r = entry $ showLens `lensMap` r {- | Notebook (tabs).@@ -247,7 +209,7 @@ The tabs are created lazily. -} notebook :: EffRef m => [(String, Widget m)] -> Widget m-notebook xs = Action $ do+notebook xs = do currentPage <- newRef 0 let f index (title, w) = (,) title $ cell (liftM (== index) $ readRef currentPage) $ \b -> case b of False -> hcat []@@ -259,7 +221,7 @@ 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+cell_ r = return . Cell (onChange True r) {- | Dynamic cell. @@ -277,12 +239,12 @@ -- | @action@ makes possible to do any 'EffRef' action while creating the widget. action :: EffRef m => m (Widget m) -> Widget m-action = Action+action = join 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+canvas w h sc me r f = return $ 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)+hscale a b c r = return $ Scale a b c (rEffect True $ readRef r, toReceive $ writeRef r)
src/LGtk/Demos/IntListEditor.hs view
@@ -62,7 +62,7 @@ , button_ (return "Copy") (return True) $ modRef list $ \xs -> take (i+1) xs ++ drop i xs ] - safeList = lens id (const . take maxi) `lensMap` list+ safeList = lens id (const $ take maxi) `lensMap` list sel = liftM (filter snd) $ readRef list