Browse Source

A crapton of changes to support real key bindings and config basics

master
Peter J. Jones 4 years ago
parent
commit
0770ce4cbd

+ 9
- 3
clockdown.cabal View File

@@ -26,17 +26,20 @@ flag maintainer
--------------------------------------------------------------------------------
library
exposed-modules:
Clockdown.Core.Action
Clockdown.Core.Binding
Clockdown.Core.Clock
Clockdown.Core.Clockdown
Clockdown.Core.Color
Clockdown.Core.Config
Clockdown.Core.Countdown
Clockdown.Core.Digital.Display
Clockdown.Core.Digital.Indicator
Clockdown.Core.Dispatch
Clockdown.Core.Properties
Clockdown.Core.Stack
Clockdown.Core.Window
Clockdown.UI.Common.Action
Clockdown.UI.Common.Binding
Clockdown.UI.Common.Dispatch
Clockdown.UI.Term.Binding
Clockdown.UI.Term.Draw
Clockdown.UI.Term.Run

@@ -50,10 +53,13 @@ library

build-depends: async >= 2.0 && < 2.1
, base >= 4.7 && < 5.0
, byline >= 0.2 && < 0.3
, colour >= 2.3 && < 2.4
, containers >= 0.5 && < 0.6
, mtl >= 2.2 && < 2.3
, text >= 0.11 && < 1.3
, time >= 1.5 && < 1.6
, transformers >= 0.4 && < 0.5
, vty >= 5.2 && < 5.3

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

src/Clockdown/UI/Common/Action.hs → src/Clockdown/Core/Action.hs View File

@@ -10,7 +10,7 @@ the LICENSE file.
-}

--------------------------------------------------------------------------------
module Clockdown.UI.Common.Action
module Clockdown.Core.Action
( Action (..)
, parseAction
) where
@@ -18,19 +18,18 @@ module Clockdown.UI.Common.Action
--------------------------------------------------------------------------------
-- Library imports:
import Data.Text (Text)
import Data.Time

--------------------------------------------------------------------------------
import Clockdown.Core.Window

--------------------------------------------------------------------------------
-- | Actions which can be triggered by the system or the user.
data Action = Tick UTCTime
data Action = Tick
-- ^ Update the clock.

| NewWindow Window
-- ^ Add a window to the end of the window list.
| NewCountdown Text
-- ^ Add a countdown window to the end of the window
-- list and then focus it.

| PrevWindow
-- ^ Focus the previous window.

| NextWindow
-- ^ Focus the next window.
@@ -38,6 +37,8 @@ data Action = Tick UTCTime
| Quit
-- ^ Quit the application.

deriving (Eq)

--------------------------------------------------------------------------------
parseAction :: Text -> Either String Action
parseAction = undefined

src/Clockdown/UI/Common/Binding.hs → src/Clockdown/Core/Binding.hs View File

@@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package clockdown. It is subject to the
@@ -13,12 +11,13 @@ the LICENSE file.

--------------------------------------------------------------------------------
-- | Functions and data types for key bindings.
module Clockdown.UI.Common.Binding
module Clockdown.Core.Binding
( KeyCode (..)
, KeyModifier (..)
, KeyMap
, makeKeyMap
, parseKeys
, processKey
, processBinding
) where

--------------------------------------------------------------------------------
@@ -30,30 +29,43 @@ import Data.Text (Text)
import Data.Word

--------------------------------------------------------------------------------
-- | Keys.
data KeyCode = RawKey Char -- ^ A normal character key.
| Escape -- ^ The escape key.
| Backspace -- ^ The backspace key.
| FKey Int -- ^ One of the F keys.
deriving (Eq, Ord)

--------------------------------------------------------------------------------
-- | Modifier keys.
data KeyModifier = Shift -- ^ The shift key.
| Control -- ^ The control key.
| Meta -- ^ The meta/alt/option key.
deriving (Eq, Enum)

--------------------------------------------------------------------------------
-- | A @KeyMap@ allows you to connect key events to some other type.
newtype KeyMap a = KeyMap {unMap :: Map (Word8, KeyCode) a}

--------------------------------------------------------------------------------
instance Functor KeyMap where
fmap f (KeyMap m) = KeyMap (Map.map f m)

--------------------------------------------------------------------------------
-- | Build a 'KeyMap' by hand using an association list.
makeKeyMap :: [(([KeyModifier], KeyCode), a)] -> KeyMap a
makeKeyMap alist = KeyMap (Map.fromList $ list alist)
where
list :: [(([KeyModifier], KeyCode), a)] -> [((Word8, KeyCode), a)]
list = map (\((ms, k), a) -> ((modsToWord ms, k), a))

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

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

--------------------------------------------------------------------------------
modsToWord :: [KeyModifier] -> Word8

+ 32
- 7
src/Clockdown/Core/Clockdown.hs View File

@@ -15,27 +15,52 @@ the LICENSE file.
module Clockdown.Core.Clockdown
( Clockdown
, ask
, asks
, get
, gets
, put
, modify
, config
, private
, liftIO
, runClockdown
) where

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

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Config
import Clockdown.Core.Stack
import Clockdown.Core.Window

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

--------------------------------------------------------------------------------
runClockdown :: (Monad m) => r -> Stack Window -> Clockdown r m a -> m a
runClockdown r s c = do (a, _, _) <- runRWST (unC c) r s
return a
newtype Clockdown r m a =
Clockdown {unC :: RWST (Env r) () (Stack Window) m a}
deriving ( Functor, Applicative, Monad, MonadIO
, MonadReader (Env r), MonadState (Stack Window)
)

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

runClockdown r cfg s c =
do (a, _, _) <- runRWST (unC c) env s
return a
where
env = Env { config = cfg
, private = r
}

+ 80
- 0
src/Clockdown/Core/Color.hs View File

@@ -0,0 +1,80 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package clockdown. It is subject to the
license terms in the LICENSE file found in the top-level directory of
this distribution and at git://pmade.com/clockdown/LICENSE. No part of
the clockdown package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Functions for working with colors. Reuses the @Color@ type from
-- the @Byline@ package.
module Clockdown.Core.Color
( Color (..)
, parseColor
, color8
, color256
) where

--------------------------------------------------------------------------------
-- Library imports:
import qualified Data.Colour.SRGB as C
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word
import System.Console.Byline.Color
import System.Console.Byline.Internal.Color

--------------------------------------------------------------------------------
-- | Parse a @Text@ value containing either one of the 8 ANSI color
-- names or a standard RGB color in hex notation.
parseColor :: Text -> Either String Color
parseColor input =
case Map.lookup input ansiColors of
Just c -> Right c
Nothing -> if length readColor == 1 && null (snd (head readColor))
then Right $ toColor (fst . head $ readColor)
else Left ("invalid color: " ++ Text.unpack input)
where
readColor :: [(C.Colour Double, String)]
readColor = C.sRGB24reads (Text.unpack input)

toColor :: C.Colour Double -> Color
toColor = ColorRGB . toRGB

toRGB :: C.Colour Double -> (Word8, Word8, Word8)
toRGB c = let x = C.toSRGB24 c in ( C.channelRed x
, C.channelGreen x
, C.channelBlue x
)

--------------------------------------------------------------------------------
-- | Returns a ANSI color code (0-7) for the given color.
color8 :: Color -> Word8
color8 = fromInteger . toInteger . fromEnum . colorAsANSI

--------------------------------------------------------------------------------
-- | Returns an index into the 256 color table for terminals.
color256 :: Color -> Word8
color256 c@(ColorCode _) = color8 c
color256 (ColorRGB c) = nearestColor c term256Locations

--------------------------------------------------------------------------------
-- | Map color names to the 8 standard ANSI colors.
ansiColors :: Map Text Color
ansiColors = Map.fromList [ ("black", black)
, ("red", red)
, ("green", green)
, ("yellow", yellow)
, ("blue", blue)
, ("magenta", magenta)
, ("cyan", cyan)
, ("white", white)
]

+ 104
- 0
src/Clockdown/Core/Config.hs View File

@@ -0,0 +1,104 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package clockdown. It is subject to the
license terms in the LICENSE file found in the top-level directory of
this distribution and at git://pmade.com/clockdown/LICENSE. No part of
the clockdown package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Clockdown.Core.Config
( Config (..)
, defConfig
, startingClock
) where

--------------------------------------------------------------------------------
-- Library imports:
import Control.Monad.IO.Class
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Time
import System.Console.Byline.Color

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Action
import Clockdown.Core.Binding
import Clockdown.Core.Clock
import Clockdown.Core.Countdown
import Clockdown.Core.Properties

--------------------------------------------------------------------------------
data Config = Config
{ configKeys :: KeyMap Action
, configClocks :: Map Text Clock
, configCountdowns :: Map Text Countdown
, configStartingClock :: Text
}

--------------------------------------------------------------------------------
defConfig :: (MonadIO m) => m Config
defConfig = do
tz <- liftIO getCurrentTimeZone

return Config { configKeys = defaultKeys
, configClocks = Map.fromList [ defaultClock tz ]
, configCountdowns = Map.fromList [ defaultCountdown ]
, configStartingClock = defaultClockName
}

--------------------------------------------------------------------------------
startingClock :: (MonadIO m) => Config -> m Clock
startingClock c =
case Map.lookup (configStartingClock c) (configClocks c) of
Nothing -> return . snd . defaultClock =<< liftIO getCurrentTimeZone
Just clock -> return clock

--------------------------------------------------------------------------------
defaultKeys :: KeyMap Action
defaultKeys =
makeKeyMap [ (([], Escape), Quit)
, (([], RawKey 'q'), Quit)
, (([], RawKey '\t'), NextWindow)
, (([Shift], RawKey '\t'), PrevWindow)
, (([], FKey 1), NewCountdown defaultCountdownName)
]

--------------------------------------------------------------------------------
defaultClockName :: Text
defaultClockName = "local"

--------------------------------------------------------------------------------
defaultClock :: TimeZone -> (Text, Clock)
defaultClock tz = (defaultClockName, clock)
where
clock :: Clock
clock = Clock props tz

props :: Properties
props = Properties { propName = defaultClockName -- %b. %d, %Y
, propColor = blue
}

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

--------------------------------------------------------------------------------
defaultCountdown :: (Text, Countdown)
defaultCountdown = (defaultCountdownName, countdown)
where
countdown :: Countdown
countdown = Countdown props 300 Nothing

props :: Properties
props = Properties { propName = defaultCountdownName
, propColor = green
}

+ 19
- 4
src/Clockdown/Core/Countdown.hs View File

@@ -12,6 +12,7 @@ the LICENSE file.
--------------------------------------------------------------------------------
module Clockdown.Core.Countdown
( Countdown (..)
, countDownStart
, countDownDigitalDisplay
, countDownSucc
, countDownPred
@@ -28,14 +29,28 @@ import Clockdown.Core.Properties

--------------------------------------------------------------------------------
data Countdown = Countdown
{ countProps :: Properties
, countEnd :: UTCTime
{ countProps :: Properties -- ^ Properties.
, countDuration :: Int -- ^ Number of seconds.
, countEnd :: Maybe UTCTime -- ^ Only set after countdown is running.
}

--------------------------------------------------------------------------------
countDownStart :: UTCTime -> Countdown -> Countdown
countDownStart t c = c { countEnd = Just endTime }
where
endTime :: UTCTime
endTime = addUTCTime (fromInteger . toInteger $ countDuration c) t

--------------------------------------------------------------------------------
countDownDigitalDisplay :: Countdown -> UTCTime -> Digital.Display
countDownDigitalDisplay c t = Digital.digitalCountDown secs
where secs = max 0 (truncate $ diffUTCTime (countEnd c) t)
countDownDigitalDisplay c t = Digital.digitalCountDown (countDownSecondsLeft c t)

--------------------------------------------------------------------------------
countDownSecondsLeft :: Countdown -> UTCTime -> Int
countDownSecondsLeft c t =
case countEnd c of
Just end -> max 0 (truncate $ diffUTCTime end t)
Nothing -> 0

--------------------------------------------------------------------------------
-- | Move a countdown forward one minute.

+ 67
- 0
src/Clockdown/Core/Dispatch.hs View File

@@ -0,0 +1,67 @@
{-

This file is part of the package clockdown. It is subject to the
license terms in the LICENSE file found in the top-level directory of
this distribution and at git://pmade.com/clockdown/LICENSE. No part of
the clockdown package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Clockdown.Core.Dispatch
( dispatch
) where

--------------------------------------------------------------------------------
-- Library imports:
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Time (UTCTime)

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Action
import Clockdown.Core.Clockdown
import Clockdown.Core.Config
import Clockdown.Core.Stack
import Clockdown.Core.Window

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

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

PrevWindow ->
put (focusLeft windows)

NextWindow ->
put (focusRight windows)

NewCountdown name ->
countdown t name

Quit ->
return ()

return t

--------------------------------------------------------------------------------
countdown :: (Monad m) => UTCTime -> Text -> Clockdown r m ()
countdown tick name = newWin name configCountdowns (newCountDownWindow tick)

--------------------------------------------------------------------------------
newWin :: (Monad m) => Text -> (Config -> Map Text a) -> (a -> Window) -> Clockdown r m ()
newWin t m f = do
c <- asks config

case Map.lookup t (m c) of
Nothing -> return ()
Just a -> modify (push (f a))

+ 7
- 1
src/Clockdown/Core/Properties.hs View File

@@ -16,11 +16,17 @@ module Clockdown.Core.Properties
) where

--------------------------------------------------------------------------------
-- Library imports:
import Data.Text (Text)

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Color

--------------------------------------------------------------------------------
data Properties = Properties
{ propName :: Text
{ propName :: Text -- ^ The name of the window.
, propColor :: Color -- ^ The main color.
-- TODO: Time color
-- TODO: string message
-- TODO: string color

+ 9
- 4
src/Clockdown/Core/Window.hs View File

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

--------------------------------------------------------------------------------
module Clockdown.Core.Window
( Window (..)
, makeClock
( Window
, newClockWindow
, newCountDownWindow
, windowTick
, windowDigitalDisplay
, windowProperties
@@ -38,8 +39,12 @@ data Window = ClockWin Clock
| CountdownWin Countdown

--------------------------------------------------------------------------------
makeClock :: Properties -> TimeZone -> Window
makeClock p = ClockWin . Clock p
newClockWindow :: UTCTime -> Clock -> Window
newClockWindow t c = windowTick t (ClockWin c)

--------------------------------------------------------------------------------
newCountDownWindow :: UTCTime -> Countdown -> Window
newCountDownWindow t c = windowTick t $ CountdownWin (countDownStart t c)

--------------------------------------------------------------------------------
windowTick :: UTCTime -> Window -> Window

+ 0
- 45
src/Clockdown/UI/Common/Dispatch.hs View File

@@ -1,47 +0,0 @@
{-

This file is part of the package clockdown. It is subject to the
license terms in the LICENSE file found in the top-level directory of
this distribution and at git://pmade.com/clockdown/LICENSE. No part of
the clockdown package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Clockdown.UI.Common.Dispatch
( dispatch
) where

--------------------------------------------------------------------------------
import Data.Time (UTCTime)

--------------------------------------------------------------------------------
import Clockdown.Core.Clockdown
import Clockdown.Core.Stack
import Clockdown.Core.Window
import Clockdown.UI.Common.Action

--------------------------------------------------------------------------------
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.
put $ fmap (windowTick t) windows
return (Just t)

NextWindow -> do
put (focusRight windows)
return Nothing

NewWindow w -> do
put (push w windows)
return Nothing

Quit -> return Nothing

+ 52
- 0
src/Clockdown/UI/Term/Binding.hs View File

@@ -0,0 +1,52 @@
{-

This file is part of the package clockdown. It is subject to the
license terms in the LICENSE file found in the top-level directory of
this distribution and at git://pmade.com/clockdown/LICENSE. No part of
the clockdown package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

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

--------------------------------------------------------------------------------
-- Library imports:
import qualified Graphics.Vty as V

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

--------------------------------------------------------------------------------
-- | Fix some Vty key events so that they report the correct keys.
fixupKeys :: V.Event -> V.Event
fixupKeys (V.EvKey V.KBackTab []) = V.EvKey (V.KChar '\t') [V.MShift]
fixupKeys e = e

--------------------------------------------------------------------------------
-- | Convert Vty events into Clockdown bindings.
convertVtyEvent :: V.Event -> Maybe ([KeyModifier], KeyCode)
convertVtyEvent (V.EvMouse{}) = Nothing
convertVtyEvent (V.EvResize{}) = Nothing
convertVtyEvent (V.EvKey key ms) = (,) (map convertMod ms) <$> convertKey key

--------------------------------------------------------------------------------
convertMod :: V.Modifier -> KeyModifier
convertMod V.MShift = Shift
convertMod V.MCtrl = Control
convertMod V.MMeta = Meta
convertMod V.MAlt = Meta

--------------------------------------------------------------------------------
convertKey :: V.Key -> Maybe KeyCode
convertKey (V.KChar c) = Just (RawKey c)
convertKey V.KEsc = Just Escape
convertKey V.KBS = Just Backspace
convertKey (V.KFun n) = Just (FKey n)
convertKey _ = Nothing

+ 26
- 17
src/Clockdown/UI/Term/Draw.hs View File

@@ -23,14 +23,15 @@ import Graphics.Vty.Prelude

--------------------------------------------------------------------------------
-- Local imports:
import qualified Clockdown.Core.Color as C
import Clockdown.Core.Digital.Display
import Clockdown.Core.Digital.Indicator
import Clockdown.Core.Properties

--------------------------------------------------------------------------------
-- | Draw a single indicator into a Vty image.
drawIndicator :: Indicator -> Image
drawIndicator ssd =
drawIndicator :: Properties -> Indicator -> Image
drawIndicator props ssd =
withBorder [ paintA F A B
, paintB F B
, paintA F G B
@@ -38,7 +39,7 @@ drawIndicator ssd =
, paintA E D C
]
where
on = defAttr `withBackColor` blue
on = defAttr `withBackColor` vtyColor (propColor props)
off = defAttr

whichAttr b = if b then on else off
@@ -55,23 +56,30 @@ drawIndicator ssd =

--------------------------------------------------------------------------------
-- | Draw the time separator into a Vty image.
drawSep :: Image
drawSep = withBorder [ string defAttr " "
, string (defAttr `withBackColor` blue) " "
, string defAttr " "
, string (defAttr `withBackColor` blue) " "
, string defAttr " "
]
drawSep :: Properties -> Image
drawSep props = withBorder [ string defAttr " "
, string (defAttr `withBackColor` c) " "
, string defAttr " "
, string (defAttr `withBackColor` c) " "
, string defAttr " "
]
where
c = vtyColor (propColor props)

--------------------------------------------------------------------------------
-- | Draw an entire display into a Vty image.
drawDisplay :: Display -> Image
drawDisplay d = horizCat [ drawIndicator (indicator0 d)
, drawIndicator (indicator1 d)
, drawSep
, drawIndicator (indicator2 d)
, drawIndicator (indicator3 d)
]
drawDisplay :: Properties -> Display -> Image
drawDisplay p d = horizCat [ drawIndicator p (indicator0 d)
, drawIndicator p (indicator1 d)
, drawSep p
, drawIndicator p (indicator2 d)
, drawIndicator p (indicator3 d)
]

--------------------------------------------------------------------------------
vtyColor :: C.Color -> Color
vtyColor c@(C.ColorCode _) = ISOColor (C.color8 c)
vtyColor c@(C.ColorRGB _) = Color240 (C.color256 c)

--------------------------------------------------------------------------------
-- | Add a border around the given images.

+ 60
- 46
src/Clockdown/UI/Term/Run.hs View File

@@ -22,70 +22,84 @@ import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import Data.Time
import Graphics.Vty
import Graphics.Vty hiding (Config)

--------------------------------------------------------------------------------
-- Local imports:
import Clockdown.Core.Action
import Clockdown.Core.Binding
import Clockdown.Core.Clockdown
import Clockdown.Core.Countdown
import Clockdown.Core.Properties
import Clockdown.Core.Config
import Clockdown.Core.Dispatch
import Clockdown.Core.Stack
import Clockdown.Core.Window
import Clockdown.UI.Common.Action
import Clockdown.UI.Common.Dispatch
import Clockdown.UI.Term.Binding
import Clockdown.UI.Term.Draw

--------------------------------------------------------------------------------
tickThread :: Chan Action -> IO ()
tickThread channel = forever $ do
now <- getCurrentTime
writeChan channel (Tick now)
threadDelay 1000000
data Env = Env
{ vty :: Vty
, channel :: Chan (UTCTime, Action)
}

--------------------------------------------------------------------------------
drawThread :: Vty -> Stack Window -> Chan Action -> IO ()
drawThread vty wins channel = runClockdown vty wins $ forever $ do
mtick <- dispatch =<< liftIO (readChan channel)
tickThread :: Clockdown Env IO ()
tickThread =
do chan <- asks (channel . private)
forever (liftIO $ go chan)
where
go chan = do
now <- getCurrentTime
writeChan chan (now, Tick)
threadDelay 1000000

--------------------------------------------------------------------------------
drawThread :: Clockdown Env IO ()
drawThread = forever $ do
env <- asks private
tick <- dispatch =<< liftIO (readChan $ channel env)
window <- gets focus
tick <- maybe (liftIO getCurrentTime) return mtick
liftIO (draw $ windowDigitalDisplay window tick)
liftIO (draw (vty env) tick window)

where
draw :: Vty -> UTCTime -> Window -> IO ()
draw v t w = do
let display = windowDigitalDisplay w t
props = windowProperties w
image = drawDisplay props display

where draw d = do
region <- displayBounds (outputIface vty)
update vty $ picForImage (centerImage region $ drawDisplay d)
region <- displayBounds (outputIface v)
update v $ picForImage (centerImage region image)

--------------------------------------------------------------------------------
-- | Temporary function for testing the drawing functions.
run :: IO ()
run = do
cfg <- standardIOConfig
vty <- mkVty cfg
channel <- newChan
ticker <- async (tickThread channel)
tz <- getCurrentTimeZone
vty' <- mkVty =<< standardIOConfig
channel' <- newChan
cfg <- defConfig
now <- getCurrentTime
windows <- (stack . newClockWindow now) <$> startingClock cfg

withAsync (drawThread vty (wins tz) channel) $ \_ -> do
go channel vty
shutdown vty
cancel ticker
let env = Env vty' channel'
clockdown = runClockdown env cfg windows

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

go chan vty = do
e <- nextEvent vty

case e of
EvKey KEsc [] -> return ()
withAsync (clockdown tickThread) $ \_ ->
withAsync (clockdown drawThread) $ \_ -> do
clockdown go
shutdown vty'

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

EvKey (KChar '1') [] -> do
now <- getCurrentTime
let end = addUTCTime 90 now
let w = CountdownWin $ Countdown (Properties "foo") end
writeChan chan (NewWindow w)
go chan vty
_ -> go chan vty
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

Loading…
Cancel
Save