Browse Source

Make the Stack type more suitable for this app, allow switching windows

master
Peter J. Jones 4 years ago
parent
commit
223a2589dd

+ 1
- 1
clockdown.cabal View File

@@ -26,7 +26,6 @@ flag maintainer
--------------------------------------------------------------------------------
library
exposed-modules:
-- Clockdown.UI.Common.Binding
Clockdown.Core.Clock
Clockdown.Core.Clockdown
Clockdown.Core.Countdown
@@ -36,6 +35,7 @@ library
Clockdown.Core.Stack
Clockdown.Core.Window
Clockdown.UI.Common.Action
Clockdown.UI.Common.Binding
Clockdown.UI.Common.Dispatch
Clockdown.UI.Term.Draw
Clockdown.UI.Term.Run

+ 1
- 0
src/Clockdown/Core/Clockdown.hs View File

@@ -16,6 +16,7 @@ module Clockdown.Core.Clockdown
( Clockdown
, ask
, get
, gets
, put
, liftIO
, runClockdown

+ 29
- 37
src/Clockdown/Core/Stack.hs View File

@@ -10,66 +10,57 @@ the LICENSE file.
-}

--------------------------------------------------------------------------------
-- | A stack type and functions to manipulate it.
module Clockdown.Core.Stack
( Stack
, stack
, push
, pop
, head
, rotateLeft
, rotateRight
, focus
, focusLeft
, focusRight
) where

--------------------------------------------------------------------------------
import Prelude hiding (head)

--------------------------------------------------------------------------------
data Stack a = Node a | List a (Stack a)
-- | A stack that can't be empty and has a focused element.
data Stack a = Stack [a] a [a]

--------------------------------------------------------------------------------
instance Functor Stack where
fmap f (Node x) = Node (f x)
fmap f (List x xs) = List (f x) (fmap f xs)
fmap f (Stack a b c) = Stack (fmap f a) (f b) (fmap f c)

--------------------------------------------------------------------------------
-- | Create a new 'Stack'.
stack :: a -> Stack a
stack = Node
stack x = Stack [] x []

--------------------------------------------------------------------------------
-- | Push an item onto the end of the stack and focus it.
push :: a -> Stack a -> Stack a
push x (Node y) = List x (Node y)
push x (List y ys) = List x (List y ys)

--------------------------------------------------------------------------------
pop :: Stack a -> (a, Stack a)
pop (Node x) = (x, Node x)
pop (List x xs) = (x, xs)

--------------------------------------------------------------------------------
rpush :: a -> Stack a -> Stack a
rpush x (Node y) = List y (Node x)
rpush x (List y ys) = List y (rpush x ys)
push x (Stack a b c) = Stack (a ++ [b] ++ c) x []

--------------------------------------------------------------------------------
rpop :: Stack a -> (a, Stack a)
rpop (Node x) = (x, Node x)
rpop (List x (Node y)) = (y, Node x)
rpop (List x xs) = let (y, ys) = rpop xs in (y, List x ys)
-- | Pop the focused item off the stack and focus the next available item.
pop :: Stack a -> Stack a
pop (Stack [] b []) = Stack [] b []
pop (Stack as _ (c:cs)) = Stack as c cs
pop (Stack a@(_:_) _ c) = Stack (init a) (last a) c

--------------------------------------------------------------------------------
head :: Stack a -> a
head (Node x) = x
head (List x _) = x
-- | Get the focused element.
focus :: Stack a -> a
focus (Stack _ b _) = b

--------------------------------------------------------------------------------
rotateLeft :: Stack a -> Stack a
rotateLeft (Node x) = Node x
rotateLeft (List x (Node y)) = List y (Node x)
rotateLeft (List x xs) = List (head xs) (rpush x . snd $ pop xs)
-- | Change the focus to the next previous element.
focusLeft :: Stack a -> Stack a
focusLeft (Stack [] b []) = Stack [] b []
focusLeft (Stack a@(_:_) b c) = Stack (init a) (last a) (b:c)
focusLeft (Stack a b c@(_:_)) = Stack (a ++ [b] ++ init c) (last c) []

--------------------------------------------------------------------------------
rotateRight :: Stack a -> Stack a
rotateRight (Node x) = Node x
rotateRight (List x (Node y)) = List y (Node x)
rotateRight (List x xs) = let (z, zs) = rpop xs in List z (List x zs)
-- | Change the focus to the previous element.
focusRight :: Stack a -> Stack a
focusRight (Stack [] b []) = Stack [] b []
focusRight (Stack as b (c:cs)) = Stack (as ++ [b]) c cs
focusRight (Stack (a:as) b c) = Stack [] a (as ++ [b] ++ c)

+ 3
- 0
src/Clockdown/UI/Common/Action.hs View File

@@ -32,6 +32,9 @@ data Action = Tick UTCTime
| NewWindow Window
-- ^ Add a window to the end of the window list.

| NextWindow
-- ^ Focus the next window.

| Quit
-- ^ Quit the application.


+ 5
- 14
src/Clockdown/UI/Common/Binding.hs View File

@@ -17,7 +17,6 @@ module Clockdown.UI.Common.Binding
( KeyCode (..)
, KeyModifier (..)
, KeyMap
, defaultKeyMap
, parseKeys
, processKey
) where
@@ -30,10 +29,6 @@ import qualified Data.Map as Map
import Data.Text (Text)
import Data.Word

--------------------------------------------------------------------------------
import Clockdown.UI.Common.Action

--------------------------------------------------------------------------------
data KeyCode = RawKey Char -- ^ A normal character key.
| Escape -- ^ The escape key.
@@ -46,23 +41,18 @@ data KeyModifier = Shift -- ^ The shift key.
deriving (Eq, Enum)

--------------------------------------------------------------------------------
newtype KeyMap = KeyMap {unMap :: Map (Word8, KeyCode) Action}
newtype KeyMap a = KeyMap {unMap :: Map (Word8, KeyCode) a}

--------------------------------------------------------------------------------
defaultKeyMap :: Either String KeyMap
defaultKeyMap = parseKeys defaultKeys
where
defaultKeys :: [(Text, Text)]
defaultKeys = [ ("q", "quit")
, ("<ESC>", "quit")
]
instance Functor KeyMap where
fmap f (KeyMap m) = KeyMap (Map.map f m)

--------------------------------------------------------------------------------
parseKeys :: [(Text, Text)] -> Either String KeyMap
parseKeys :: [(Text, a)] -> Either String (KeyMap a)
parseKeys = undefined

--------------------------------------------------------------------------------
processKey :: [KeyModifier] -> KeyCode -> KeyMap -> Maybe Action
processKey :: [KeyModifier] -> KeyCode -> KeyMap a -> Maybe a
processKey mods key = Map.lookup (modsToWord mods, key) . unMap

--------------------------------------------------------------------------------

+ 11
- 9
src/Clockdown/UI/Common/Dispatch.hs View File

@@ -21,25 +21,27 @@ import Data.Time (UTCTime)
--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Clockdown
import qualified Clockdown.Core.Stack as S
import Clockdown.Core.Stack
import Clockdown.Core.Window
import Clockdown.UI.Common.Action

--------------------------------------------------------------------------------
dispatch :: (Monad m) => Action -> Clockdown r m (Maybe UTCTime, Window)
dispatch :: (Monad m) => Action -> Clockdown r m (Maybe UTCTime)
dispatch a = do
windows <- get

case a of
Tick t -> do
-- Update all windows, then return the main window.
let windows' = fmap (windowTick t) windows
put windows'
return (Just t, S.head windows')
put $ fmap (windowTick t) windows
return (Just t)

NextWindow -> do
put (focusRight windows)
return Nothing

NewWindow w -> do
let windows' = S.push w windows
put windows'
return (Nothing, w)
put (push w windows)
return Nothing

Quit -> return (Nothing, S.head windows)
Quit -> return Nothing

+ 11
- 6
src/Clockdown/UI/Term/Run.hs View File

@@ -29,7 +29,7 @@ import Graphics.Vty
import Clockdown.Core.Clockdown
import Clockdown.Core.Countdown
import Clockdown.Core.Properties
import qualified Clockdown.Core.Stack as S
import Clockdown.Core.Stack
import Clockdown.Core.Window
import Clockdown.UI.Common.Action
import Clockdown.UI.Common.Dispatch
@@ -43,11 +43,11 @@ tickThread channel = forever $ do
threadDelay 1000000

--------------------------------------------------------------------------------
drawThread :: Vty -> S.Stack Window -> Chan Action -> IO ()
drawThread :: Vty -> Stack Window -> Chan Action -> IO ()
drawThread vty wins channel = runClockdown vty wins $ forever $ do
action <- liftIO (readChan channel)
(mtick, window) <- dispatch action
tick <- maybe (liftIO getCurrentTime) return mtick
mtick <- dispatch =<< liftIO (readChan channel)
window <- gets focus
tick <- maybe (liftIO getCurrentTime) return mtick
liftIO (draw $ windowDigitalDisplay window tick)

where draw d = do
@@ -70,13 +70,18 @@ run = do
cancel ticker

where
wins tz = S.stack (makeClock (Properties "foo") tz)
wins tz = stack (makeClock (Properties "foo") tz)

go chan vty = do
e <- nextEvent vty

case e of
EvKey KEsc [] -> return ()

EvKey (KChar 'n') [] -> do
writeChan chan NextWindow
go chan vty

EvKey (KChar '1') [] -> do
now <- getCurrentTime
let end = addUTCTime 90 now

Loading…
Cancel
Save