{-# LANGUAGE OverloadedStrings, RankNTypes, TupleSections #-}
module Ham.UI.Brick
(
emptyAppState
, AppMode(..)
, AppState(..)
, AppResource
, app
)
where
import Ham.Log
import Ham.Data
import qualified Ham.CAT as CAT
import Ham.CAT.ElecraftKX2
import Ham.CAT.YaesuFT891
import qualified Ham.Internal.FixedSequence as FS
import Ham.Internal.FixedSequence (FixedSequence)
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Monoid ((<>))
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Time.Format (formatTime, defaultTimeLocale)
import qualified Data.Text as T
import Data.Text (Text)
import Data.Foldable
import Data.List (foldl')
import qualified Data.Text as Text
import qualified Data.Sequence as S
import qualified Data.Vector as V
import Brick
import Brick.Forms
import Brick.Widgets.List
import Brick.Widgets.Border
import Brick.Widgets.Dialog
import qualified Brick.Widgets.Edit as E
import qualified Brick.Focus as F
import qualified Brick.Types as T
import Brick.Main
import qualified Brick.Widgets.Border.Style
import Graphics.Vty.Attributes (defAttr, blue)
import Graphics.Vty.Input.Events
import qualified Graphics.Vty as V
import Lens.Micro
data AppState = AppState {
logState :: LogState,
logConfig :: LogConfig,
qsoList :: List AppResource Qso,
qsoForm :: Form Qso HamlogEvent AppResource,
focusRing :: F.FocusRing AppResource,
appMode :: AppMode,
selectedQsoIndex :: Int,
infoText :: FixedSequence Text,
statusText :: [Text],
duplicateQsos :: S.Seq Duplicate
}
emptyAppState :: AppState
emptyAppState =
AppState { logState = emptyLogState,
logConfig = defaultConfig,
qsoList = list LogList V.empty 1,
qsoForm = newForm [] emptyQso,
focusRing = lappDefaultFocusRing,
appMode = AppModeList,
selectedQsoIndex = 0,
infoText = FS.emptyFS 10,
statusText = [],
duplicateQsos = S.Empty
}
data HamlogEvent
data AppResource = LogList |
LogInfo |
LogQso |
LogQsoTimeStart |
LogQsoTimeEnd |
LogQsoFrequency |
LogQsoMode |
LogQsoCallsign |
LogQsoLocation |
LogQsoRST |
LogQsoExchange |
LogQsoMyCallsign |
LogQsoMyLocation |
LogQsoSentRST |
LogQsoSentExchange |
LogQsoNotes
deriving (Eq, Ord, Show)
hamLog :: AppState -> HamLog a -> EventM AppResource (a, AppState)
hamLog s act = do
(a, ls, logtext) <- liftIO $ runHamLog (logConfig s) (logState s) $ act
let s' = s { logState = ls,
infoText = fs,
logConfig = (logConfig s) { _configUseCat = _stateUseCat ls } }
fs = foldr FS.addElement (infoText s) logtext
return (a, s')
lappDefaultFocusRing :: F.FocusRing AppResource
lappDefaultFocusRing = F.focusRing []
lappQsoFocusRing :: AppState -> F.FocusRing AppResource
lappQsoFocusRing s = formFocus $ qsoForm s
lappNewQso :: AppState -> EventM AppResource AppState
lappNewQso s = do
(q, s') <- hamLog s newQsoNow
s'' <- lupdateQsoList 0 s' >>= lupdateQsoForm
return $ s'' { appMode = AppModeQso, focusRing = lappQsoFocusRing s'', selectedQsoIndex = 0 }
mkQsoForm :: Qso -> QsoDefaults -> Form Qso HamlogEvent AppResource
mkQsoForm q q_def = newForm fieldStates q
where
timeStart = f _qsoDefaultTimeStart $ label "Start:" @@= editShowableField qsoTimeStart LogQsoTimeStart
timeEnd = f _qsoDefaultTimeEnd $ label "End:" @@= editShowableField qsoTimeEnd LogQsoTimeEnd
f d s = case d q_def of
FixedValue _ -> []
DefaultValue _ -> [s]
fieldStates = concat [
f _qsoDefaultCallsign $ label "Callsign:" @@= editTextField qsoCallsign LogQsoCallsign (Just 1),
f _qsoDefaultLocation $ label "Location:" @@= editTextField qsoLocation LogQsoLocation (Just 1),
f _qsoDefaultRST $ label "RST received:" @@= editShowableField qsoRST LogQsoRST,
f _qsoDefaultExchange $ label "Exchg recvd:" @@= editTextField qsoExchange LogQsoExchange (Just 1),
f _qsoDefaultSentRST $ label "RST sent:" @@= editShowableField qsoSentRST LogQsoSentRST,
f _qsoDefaultSentExchange $ label "Exchg sent:" @@= editTextField qsoSentExchange LogQsoSentExchange (Just 1),
f _qsoDefaultFrequency $ label "Frequency:" @@= editShowableField qsoFrequency LogQsoFrequency,
f _qsoDefaultMode $ label "Mode (CW,PH,FM,RY):" @@= editShowableField qsoMode LogQsoMode,
f _qsoDefaultSentCallsign $ label "My callsign:" @@= editTextField qsoSentCallsign LogQsoMyCallsign (Just 1),
f _qsoDefaultSentLocation $ label "My location:" @@= editTextField qsoSentLocation LogQsoMyLocation (Just 1),
timeStart,
timeEnd,
f _qsoDefaultNotes $ label "Notes:" @@= editTextField qsoNotes LogQsoNotes Nothing]
label s w =
(vLimit 1 $ hLimit 20 $ str s <+> fill ' ') <+> w
mkSelectedQsoForm :: AppState -> Form Qso HamlogEvent AppResource
mkSelectedQsoForm s = qsoForm
where
q_def = _configQsoDefaults $ logConfig s
qsoForm = mkQsoForm selectedQso q_def
selectedQso = maybe emptyQso id $ snd <$> listSelectedElement (qsoList s)
lselectedQso :: AppState -> Qso
lselectedQso s = maybe emptyQso id $ snd <$> listSelectedElement (qsoList s)
lappDraw :: AppState -> [Widget AppResource]
lappDraw s = case (appMode s) of
AppModeQuestion _ dlg _ _ -> [ renderDialog dlg $ str "", mainView ]
_ -> [ mainView ]
where
mainView = ((renderListWidget <=> lappStatusTextWidget s) <+> (qsoWidget <=> lappHelp s <=> appInfoWidget s)) <=> statusWidget
renderListWidget = border $ hLimit 30 $ renderList lrenderLogListItem True l
l = qsoList s
qsoWidget = border $ renderForm $ qsoForm s
statusWidget = lappStatusWidget s
lappStatusTextWidget :: AppState -> Widget AppResource
lappStatusTextWidget s = str t
where t = unlines $ map T.unpack $ statusText s
appInfoWidget :: AppState -> Widget AppResource
appInfoWidget s = info
where info = padTop (Pad 1) $ borderWithLabel (str "Info") body
body = case (appMode s) of
_ -> vLimitPercent 30 $ viewport LogInfo Both $ vBox $ fmap txt (FS.toList $ infoText s) <> toList (fmap f dupes)
where
dupes = duplicateQsos s
dupeToText dupe = T.pack $ show dupe
f dupe = if (duplicateBand dupe) && (duplicateMode dupe)
then withAttr "dupeWarn" $ txt $ dupeToText dupe
else txt $ dupeToText dupe
lrenderLogListItem :: Bool -> Qso -> Widget AppResource
lrenderLogListItem True q = withAttr ("qsoList" <> "selected") $ str $ lrenderLogListItem_str q
lrenderLogListItem False q = withAttr ("qsoList" <> "normal") $ str $ lrenderLogListItem_str q
lrenderLogListItem_str :: Qso -> String
lrenderLogListItem_str q = time_date ++ " " ++ call ++ " " ++ bd ++ " " ++ mode
where time_date = formatTime defaultTimeLocale "%F %R" (_qsoTimeStart q)
call = Text.unpack (_qsoCallsign q)
bd = show $ band $ _qsoFrequency q
mode = show $ _qsoMode q
lupdateQsoList :: Int -> AppState -> EventM AppResource AppState
lupdateQsoList qso_index s = return $ s { qsoList = l }
where
l = listMoveTo qso_index $ list LogList ll 1
ll = V.fromList $ (foldr (:) [] . _logQsos . _stateLog . logState) s
lupdateQsoForm :: AppState -> EventM AppResource AppState
lupdateQsoForm s = return $ s { qsoForm = mkSelectedQsoForm s }
lhandleEvent_question :: AppState -> BrickEvent AppResource HamlogEvent -> EventM AppResource (Next AppState)
lhandleEvent_question s ev =
case appMode s of
AppModeQuestion prev dlg yes no ->
case ev of
VtyEvent (EvKey KEnter []) -> do
let msel = dialogSelection dlg
let s' = s { appMode = prev }
case msel of
Just sel -> continue =<< if sel then (yes s') else (no s')
VtyEvent (EvKey (KChar 'y') []) -> do
let s' = s { appMode = prev }
continue =<< yes s'
VtyEvent (EvKey (KChar 'n') []) -> do
let s' = s { appMode = prev }
continue =<< no s'
VtyEvent (EvKey KEsc []) -> do
let s' = s { appMode = prev }
continue =<< no s'
VtyEvent e -> do
dlg' <- handleDialogEvent e dlg
let s' = s { appMode = AppModeQuestion prev dlg' yes no }
continue s'
_ -> continue s
_ -> continue s
lhandleEvent_list :: AppState -> BrickEvent AppResource HamlogEvent -> EventM AppResource (Next AppState)
lhandleEvent_list s ev =
case appMode s of
AppModeList ->
case ev of
VtyEvent (EvKey (KChar 'q') []) -> do
(_, s') <- hamLog s writeLog
halt s'
VtyEvent (EvKey (KChar 'n') []) -> do
let
updated_qso_defaults = qso_defaults {
_qsoDefaultFrequency = case _qsoDefaultFrequency qso_defaults of
DefaultValue f -> DefaultValue f
a -> a,
_qsoDefaultMode = case _qsoDefaultMode qso_defaults of
DefaultValue m -> DefaultValue m
a -> a }
qso_defaults = _configQsoDefaults $ logConfig s
updated_config = (logConfig s) { _configQsoDefaults = updated_qso_defaults }
s' = s { logConfig = updated_config }
continue =<< lappNewQso s'
VtyEvent (EvKey KBS []) -> do
let dlg = dialog (Just "Delete entry?") (Just (1, [("Yes", True), ("No", False)])) 25
s' = s { appMode = AppModeQuestion AppModeList dlg yes no }
yes ss = maybe
(return ss)
(\i -> snd <$> hamLog ss (deleteQso i) >>=
lupdateQsoList i >>=
lupdateQsoForm >>= \ss' ->
lcheckDupes (lselectedQso ss') ss')
mi
no = return
mi = listSelected $ qsoList s'
continue s'
VtyEvent (EvKey (KChar 's') []) -> continue $ s { appMode = AppModeSort AppModeList }
VtyEvent (EvKey (KChar 'w') []) -> snd <$> hamLog s writeLog >>= continue
VtyEvent (EvKey (KChar '\t') []) -> do
let mi = listSelected $ qsoList s
case mi of
Just i -> continue $ s { appMode = AppModeQso, focusRing = lappQsoFocusRing s, selectedQsoIndex = i }
Nothing -> continue s
VtyEvent e -> do
s' <- handleListEvent e (qsoList s) >>= \l -> return (s { qsoList = l })
continue =<< lupdateQsoForm s'
_ -> continue s
_ -> continue s
lhandleEvent_qso :: AppState -> BrickEvent AppResource HamlogEvent -> EventM AppResource (Next AppState)
lhandleEvent_qso s ev =
case (appMode s) of
AppModeQso ->
case ev of
VtyEvent (EvKey KUp []) -> do
let focusring = lappQsoFocusRing s
m_current_focus = F.focusGetCurrent focusring
case m_current_focus of
Just LogQsoNotes ->
handleFormEvent ev (qsoForm s) >>= \f ->
continue $ s { qsoForm = f, focusRing = lappQsoFocusRing s }
Just _ -> lhandleEvent_qso s (VtyEvent (EvKey KBackTab []))
VtyEvent (EvKey KDown []) -> do
let focusring = lappQsoFocusRing s
m_current_focus = F.focusGetCurrent focusring
case m_current_focus of
Just LogQsoNotes ->
handleFormEvent ev (qsoForm s) >>= \f ->
continue $ s { qsoForm = f, focusRing = lappQsoFocusRing s }
Just _ -> lhandleEvent_qso s (VtyEvent (EvKey (KChar '\t') []))
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> do
let f = formState $ qsoForm s
let s' = s { statusText = ["[Retrieving...]"] }
(name, s') <- hamLog s $ lookupFccName (_qsoCallsign f)
continue $ s' { statusText = [name] }
VtyEvent (EvKey (KChar 't') [MCtrl]) -> do
let f = formState $ qsoForm s
s' = s { statusText = ["Time updated"] }
i = selectedQsoIndex s'
(mf', s'') <- hamLog s' $ do
currentUtcTime >>= \t -> updateQso i (f { _qsoTimeStart = t, _qsoTimeEnd = t })
a <- getQsoSeq
return (a S.!? i)
lupdateQsoForm s'' >>= continue
VtyEvent (EvKey KEsc []) -> do
let f = formState $ qsoForm s
i = selectedQsoIndex s
updated_qso_defaults = qso_defaults { _qsoDefaultFrequency = case _qsoDefaultFrequency qso_defaults of
DefaultValue _ -> DefaultValue (_qsoFrequency f)
a -> a
, _qsoDefaultMode = case _qsoDefaultMode qso_defaults of
DefaultValue _ -> DefaultValue (_qsoMode f) }
qso_defaults = _configQsoDefaults $ logConfig s
updated_config = (logConfig s) { _configQsoDefaults = updated_qso_defaults }
s' <- (hamLog s $ updateQso i f) >>= lcheckDupes f . snd
let s'' = s' { appMode = AppModeList,
focusRing = lappDefaultFocusRing,
logConfig = updated_config,
selectedQsoIndex = -1 }
continue =<< lupdateQsoList i s''
_ -> do
s' <- handleFormEvent ev (qsoForm s) >>= \f ->
return (s { qsoForm = f }) >>= \ss ->
return (ss { focusRing = lappQsoFocusRing ss })
continue s'
_ -> continue s
lcheckDupes :: Qso -> AppState -> EventM AppResource AppState
lcheckDupes qso s = do
(dupes, s') <- hamLog s $ findDuplicateQsos qso
return $ s' { duplicateQsos = dupes }
data QsoSortKey = QsoSortTime
| QsoSortCallsign
| QsoSortLocation
lsetAppMode :: AppMode -> AppState -> EventM AppResource AppState
lsetAppMode m s = return $ s { appMode = m }
lhandleEvent_sortQsos :: AppState -> BrickEvent AppResource HamlogEvent -> EventM AppResource (Next AppState)
lhandleEvent_sortQsos s ev =
case appMode s of
AppModeSort prev -> do
ms' <- case ev of
VtyEvent (EvKey (KChar 't') []) -> snd <$> hamLog s (sortLog _qsoTimeStart) >>= lsetAppMode prev >>= return . Just
VtyEvent (EvKey (KChar 'c') []) -> snd <$> hamLog s (sortLog _qsoCallsign) >>= lsetAppMode prev >>= return . Just
VtyEvent (EvKey (KChar 'l') []) -> snd <$> hamLog s (sortLog _qsoLocation) >>= lsetAppMode prev >>= return . Just
_ -> return Nothing
maybe (continue s) (\s' -> lupdateQsoList 0 s' >>= lupdateQsoForm >>= continue) ms'
_ -> continue s
lappStatusWidget :: AppState -> Widget AppResource
lappStatusWidget _ = str $ "(C) Copyright KM6THJ, 2018."
lappHelp :: AppState -> Widget AppResource
lappHelp s = help
where help = padTop (Pad 1) $ borderWithLabel (str "Help") body
body = case (appMode s) of
AppModeList -> str $ "- n: New qso Del: Delete qso\n" <>
"- Tab: Edit s: Sort Log\n" <>
"- w: Write to file q: Quit"
AppModeQso -> str $ "- Esc: End edit and accept results\n" <>
"- Tab: Cycle entries\n" <>
"- Ctrl-l: Lookup name for callsign"
AppModeSort _ -> str $ "- t: Sort by time\n" <>
"- c: Sort by callsign\n" <>
"- l: Sort by location"
_ -> str ""
data AppMode = AppModeList
| AppModeQso
| AppModeQuestion
{ appModeQuestionPrev :: AppMode,
appModeQuestionDialog :: Dialog Bool,
appModeQuestionYes :: (AppState -> EventM AppResource AppState),
appModeQuestionNo :: (AppState -> EventM AppResource AppState) }
| AppModeSort
{ appModeSortPrev :: AppMode }
lhandleEvent :: AppState -> BrickEvent AppResource HamlogEvent -> EventM AppResource (Next AppState)
lhandleEvent s ev = do
case (appMode s) of
AppModeList -> lhandleEvent_list s ev
AppModeQuestion prev dlg yes no -> lhandleEvent_question s ev
AppModeQso -> lhandleEvent_qso s ev
AppModeSort prev -> lhandleEvent_sortQsos s ev
lappCursor :: AppState -> [T.CursorLocation AppResource] -> Maybe (T.CursorLocation AppResource)
lappCursor = F.focusRingCursor focusRing
lappStartEvent s = (snd <$> hamLog s readLog) >>= lupdateQsoList 0 >>= lupdateQsoForm
app = App { appDraw = lappDraw
, appHandleEvent = lhandleEvent
, appStartEvent = lappStartEvent
, appAttrMap = const $ attrMap defAttr
[
(E.editAttr, V.white `on` V.black)
, (E.editFocusedAttr, V.black `on` V.yellow)
, (invalidFormInputAttr, V.white `on` V.red)
, (focusedFormInputAttr, V.black `on` V.yellow)
, (attrName "qsoList" <> attrName "selected", V.black `on` V.yellow)
, (attrName "qsoList" <> attrName "normal", defAttr)
, (attrName "dupeWarn", V.white `on` V.red)
, (buttonAttr, V.black `on` V.white)
, (buttonSelectedAttr, V.black `on` V.green)
]
, appChooseCursor = lappCursor }