ソースを参照

Add window closing

master
Peter J. Jones 4年前
コミット
4dfbf8b2d9

+ 9
- 2
src/Clockdown/Core/Action.hs ファイルの表示

@@ -40,8 +40,15 @@ data Action = Tick
| TimePred
-- ^ Update the time in the focused window.

-- FIXME: CloseWindow
-- FIXME: CloseWindowOrQuit
| CloseWindow
-- ^ Close the focused window. If the focused window is
-- the only window, this action does nothing.

| CloseWindowOrQuit
-- ^ Like @CloseWindow@, except that if the focused
-- window is the only window then the application will
-- quit.

-- FIXME: ResetTime

| Quit

+ 13
- 4
src/Clockdown/Core/Clockdown.hs ファイルの表示

@@ -23,12 +23,14 @@ module Clockdown.Core.Clockdown
, config
, private
, liftIO
, quit
, runClockdown
) where

--------------------------------------------------------------------------------
-- Library imports:
import Control.Monad.RWS
import Control.Monad.Trans.Maybe

--------------------------------------------------------------------------------
-- Local imports:
@@ -44,22 +46,29 @@ data Env r = Env

--------------------------------------------------------------------------------
newtype Clockdown r m a =
Clockdown {unC :: RWST (Env r) () (Stack Window) m a}
Clockdown {unC :: RWST (Env r) () (Stack Window) (MaybeT m) a}
deriving ( Functor, Applicative, Monad, MonadIO
, MonadReader (Env r), MonadState (Stack Window)
)

--------------------------------------------------------------------------------
quit :: (Monad m) => Clockdown r m a
quit = Clockdown $ lift (MaybeT $ return Nothing)

--------------------------------------------------------------------------------
runClockdown :: (Monad m)
=> r
-> Config
-> Stack Window
-> Clockdown r m a
-> m a
-> m (Maybe a)

runClockdown r cfg s c =
do (a, _, _) <- runRWST (unC c) env s
return a
do result <- runMaybeT $ runRWST (unC c) env s
case result of
Nothing -> return Nothing
Just (a, _, _) -> return (Just a)

where
env = Env { config = cfg
, private = r

+ 4
- 4
src/Clockdown/Core/Config.hs ファイルの表示

@@ -65,7 +65,7 @@ startingClock c =
defaultKeys :: KeyMap Action
defaultKeys =
makeKeyMap [ (([], Escape), Quit)
, (([], RawKey 'q'), Quit)
, (([], RawKey 'q'), CloseWindowOrQuit)
, (([], RawKey '\t'), NextWindow)
, (([Shift], RawKey '\t'), PrevWindow)
, (([], RawKey '='), TimeSucc)
@@ -96,7 +96,7 @@ defaultClock tz = (defaultClockName, clock)

--------------------------------------------------------------------------------
defaultCountdownName :: Text
defaultCountdownName = "five"
defaultCountdownName = "ten"

--------------------------------------------------------------------------------
defaultCountdown :: (Text, Countdown)
@@ -105,8 +105,8 @@ defaultCountdown = (defaultCountdownName, countdown)
countdown :: Countdown
countdown = Countdown { countProps = props
, countDoneColor = Just red
, countColorChange = 59
, countDuration = 300
, countColorChange = 120
, countDuration = 600
, countEnd = Nothing
, countOrigColor = Nothing
}

+ 8
- 2
src/Clockdown/Core/Dispatch.hs ファイルの表示

@@ -36,7 +36,6 @@ dispatch (t, a) = do

case a of
Tick ->
-- Update all windows with the current tick.
put $ fmap (windowTick t) windows

PrevWindow ->
@@ -54,8 +53,15 @@ dispatch (t, a) = do
TimePred ->
put (withFocused windows $ windowPred t)

CloseWindow ->
put (pop windows)

CloseWindowOrQuit
| stackLenght windows == 1 -> quit
| otherwise -> put (pop windows)

Quit ->
return ()
quit

return t


+ 5
- 0
src/Clockdown/Core/Stack.hs ファイルの表示

@@ -14,6 +14,7 @@ the LICENSE file.
module Clockdown.Core.Stack
( Stack
, stack
, stackLenght
, withFocused
, push
, pop
@@ -35,6 +36,10 @@ instance Functor Stack where
stack :: a -> Stack a
stack x = Stack [] x []

--------------------------------------------------------------------------------
stackLenght :: Stack a -> Int
stackLenght (Stack a _ c) = length a + length c + 1

--------------------------------------------------------------------------------
-- | Apply a function to the focused element.
withFocused :: Stack a -> (a -> a) -> Stack a

+ 9
- 2
src/Clockdown/UI/Term/Binding.hs ファイルの表示

@@ -11,8 +11,7 @@ the LICENSE file.

--------------------------------------------------------------------------------
module Clockdown.UI.Term.Binding
( fixupKeys
, convertVtyEvent
( eventToAction
) where

--------------------------------------------------------------------------------
@@ -21,7 +20,15 @@ import qualified Graphics.Vty as V

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Action
import Clockdown.Core.Binding
import Clockdown.Core.Config

--------------------------------------------------------------------------------
eventToAction :: V.Event -> Config -> Maybe Action
eventToAction e c = do
key <- convertVtyEvent (fixupKeys e)
processBinding (configKeys c) key

--------------------------------------------------------------------------------
-- | Fix some Vty key events so that they report the correct keys.

+ 20
- 20
src/Clockdown/UI/Term/Run.hs ファイルの表示

@@ -27,7 +27,6 @@ import Graphics.Vty hiding (Config)
--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Action
import Clockdown.Core.Binding
import Clockdown.Core.Clockdown
import Clockdown.Core.Config
import Clockdown.Core.Dispatch
@@ -67,6 +66,19 @@ drawThread = forever $ do
region <- displayBounds (outputIface v)
update v (picForImage $ drawWindow t w region)

--------------------------------------------------------------------------------
eventThread :: Clockdown Env IO ()
eventThread = asks config >>= \c -> forever $ do
e <- liftIO . nextEvent =<< asks (vty . private)
maybe (return ()) send (eventToAction e c)

where
send :: Action -> Clockdown Env IO ()
send action =
do now <- liftIO getCurrentTime
chan <- asks (channel . private)
liftIO (writeChan chan (now, action))

--------------------------------------------------------------------------------
-- | Temporary function for testing the drawing functions.
run :: IO ()
@@ -78,24 +90,12 @@ run = do
windows <- (stack . newClockWindow now) <$> startingClock cfg

let env = Env vty' channel'
clockdown = runClockdown env cfg windows
clockdown = void . runClockdown env cfg windows

withAsync (clockdown tickThread) $ \_ ->
withAsync (clockdown drawThread) $ \_ -> do
clockdown go
shutdown vty'
threads <- sequence [ async (clockdown tickThread)
, async (clockdown drawThread)
, async (clockdown eventThread)
]

where
go :: Clockdown Env IO ()
go = do
e <- liftIO . nextEvent =<< asks (vty . private)
c <- asks config

case convertVtyEvent (fixupKeys e) >>= processBinding (configKeys c) of
Nothing -> go
Just action -> if action == Quit
then return ()
else do now <- liftIO getCurrentTime
chan <- asks (channel . private)
liftIO (writeChan chan (now, action))
go
_ <- waitAnyCatchCancel threads
shutdown vty'

読み込み中…
キャンセル
保存