Config registry

app/CLI.hs

@@ -7,15 +7,15 @@ import Options.Applicative
 data CLIOptions = CLIOptions
     { cliSampleAmount :: Maybe Int
     , cliWeights :: [(Text, Int)]
-    , cliConfigPath :: FilePath
+    , cliConfigPath :: Maybe FilePath
     }
 
 cliParser :: Parser CLIOptions
 cliParser =
     CLIOptions
         <$> optional sampleAmount
         <*> many weights
-        <*> argument str (metavar "<config.json>")
+        <*> optional (argument str (metavar "<config.json>"))
   where
     sampleAmount =
         option

app/Main.hs

@@ -11,11 +11,13 @@ import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
 import Graphics.Vty qualified as V
 import Graphics.Vty.CrossPlatform (mkVty)
+import Registry (loadRegistry, registerConfig)
 import Sampling (SamplingStrategy (..), sampleQuestions)
 import State (AppState, Name, initialState)
 import System.Exit (exitFailure)
 import System.Random (newStdGen)
 import TUI.Attributes (theMap)
+import TUI.ConfigSelect (selectConfig)
 import TUI.Draw (drawUI)
 import TUI.Event (CustomEvent (..), handleEvent)
 import Types (Config (..))
@@ -34,18 +36,33 @@ main :: IO ()
 main = do
     opts <- parseCLIOpts
 
-    configBytes <- BS.readFile (cliConfigPath opts)
+    configPath <- case cliConfigPath opts of
+        Just p -> pure p
+        Nothing -> do
+            registry <- loadRegistry
+            if null registry
+                then do
+                    putStrLn "No config path provided and no previously-used configs found."
+                    putStrLn "Usage: cert-prep <config.json>"
+                    exitFailure
+                else do
+                    mPath <- selectConfig registry
+                    maybe exitFailure pure mPath
+
+    configBytes <- BS.readFile configPath
     config <- case eitherDecodeStrict configBytes of
         Left err -> do
             putStrLn $ "Error parsing config: " ++ err
             exitFailure
         Right c -> return c
 
-    let sampleSize = fromMaybe (configSampleAmount config) (cliSampleAmount opts)
+    registerConfig configPath (title config)
+
+    let sampleSize = fromMaybe (sampleAmount config) (cliSampleAmount opts)
         strategy = case cliWeights opts of
-            [] -> maybe Uniform Stratified $ configCategoryWeights config
+            [] -> maybe Uniform Stratified $ categoryWeights config
             ws -> Stratified (Map.fromList ws)
-        allQuestions = configQuestions config
+        allQuestions = questions config
         effectiveSize = min sampleSize (length allQuestions)
 
     gen <- newStdGen

app/TUI/ConfigSelect.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module TUI.ConfigSelect (selectConfig) where
+
+import Brick
+import Brick.Widgets.Border
+import Brick.Widgets.Border.Style
+import Brick.Widgets.Center
+import Brick.Widgets.List qualified as L
+import Data.Time (defaultTimeLocale, formatTime)
+import Data.Vector qualified as V
+import Graphics.Vty qualified as Vty
+import Graphics.Vty.CrossPlatform (mkVty)
+import Lens.Micro.TH (makeLenses)
+import Registry (Registry, RegistryEntry (..))
+
+data SelectName = SelectList
+    deriving (Show, Eq, Ord)
+
+newtype SelectState = SelectState
+    { _selectList :: L.List SelectName RegistryEntry
+    }
+
+makeLenses ''SelectState
+
+drawSelectUI :: SelectState -> [Widget SelectName]
+drawSelectUI (SelectState l) = [ui]
+  where
+    ui =
+        withBorderStyle unicode $
+            borderWithLabel (str " Select a Config ") $
+                center $
+                    hLimitPercent 80 $
+                        vLimitPercent 80 $
+                            vBox
+                                [ L.renderList renderEntry True l
+                                , hBorder
+                                , padLeftRight 1 $
+                                    str "[Enter] Select  [q/Esc] Quit  [Arrow Keys] Navigate"
+                                ]
+
+renderEntry :: Bool -> RegistryEntry -> Widget SelectName
+renderEntry selected entry =
+    let marker = if selected then ">" else " "
+        p = path entry
+        time =
+            formatTime
+                defaultTimeLocale
+                "%Y-%m-%d %H:%M"
+                (lastUsed entry)
+     in hBox
+            [ str marker
+            , str " "
+            , txt $ title entry
+            , padLeft Max $ str (time ++ "  " ++ p)
+            ]
+
+handleSelectEvent ::
+    BrickEvent SelectName e -> EventM SelectName SelectState ()
+handleSelectEvent (VtyEvent (Vty.EvKey Vty.KEsc [])) = halt
+handleSelectEvent (VtyEvent (Vty.EvKey Vty.KEnter [])) = halt
+handleSelectEvent (VtyEvent (Vty.EvKey (Vty.KChar c) [])) = case c of
+    'j' -> handleSelectEvent (VtyEvent (Vty.EvKey Vty.KDown []))
+    'k' -> handleSelectEvent (VtyEvent (Vty.EvKey Vty.KUp []))
+    'q' -> halt
+    _ -> return ()
+handleSelectEvent (VtyEvent e) = do
+    zoom selectList $ L.handleListEvent e
+handleSelectEvent _ = return ()
+
+selectConfig :: Registry -> IO (Maybe FilePath)
+selectConfig entries = do
+    let list =
+            L.list
+                SelectList
+                (V.fromList entries)
+                1
+        initial = SelectState list
+        app =
+            App
+                { appDraw = drawSelectUI
+                , appChooseCursor = neverShowCursor
+                , appHandleEvent = handleSelectEvent
+                , appStartEvent = return ()
+                , appAttrMap =
+                    const $
+                        attrMap
+                            Vty.defAttr
+                            [(L.listSelectedFocusedAttr, Vty.defAttr `Vty.withStyle` Vty.reverseVideo)]
+                }
+    let buildVty = mkVty Vty.defaultConfig
+    initialVty <- buildVty
+    finalState <- customMain initialVty buildVty Nothing app initial
+    let mSelected = snd <$> L.listSelectedElement (_selectList finalState)
+    pure (path <$> mSelected)

app/TUI/Draw.hs

@@ -62,49 +62,47 @@ drawExam s =
         ]
   where
     mQuestion = currentQuestion s
-
     questionPanel =
-        withBorderStyle unicode $
-            borderWithLabel
+        withBorderStyle unicode
+            $ borderWithLabel
                 ( str $
                     " Question " ++ show (s ^. currentIndex + 1) ++ " of " ++ show (totalQuestions s) ++ " "
-                ) $
-                hLimitPercent 50 $
-                    padAll 1 $
-                        case mQuestion of
-                            Nothing -> str "No question"
-                            Just q -> txtWrap (questionText q)
+                )
+            $ padAll 1
+            $ case mQuestion of
+                Nothing -> str "No question"
+                Just q -> txtWrap (text q)
 
     answersPanel =
         withBorderStyle unicode $
             borderWithLabel (str " Answers ") $
-                hLimitPercent 50 $
-                    padAll 1 $
-                        case mQuestion of
-                            Nothing -> str "No answers"
-                            Just q ->
-                                let result = evalAnswer q (s ^. selectedAnswers)
-                                 in vBox $ zipWith (drawAnswer s result) [0 ..] (questionAnswerChoices q)
+                padAll 1 $
+                    case mQuestion of
+                        Nothing -> str "No answers"
+                        Just q ->
+                            let result = evalAnswer q (s ^. selectedAnswers)
+                             in vBox $ zipWith (drawAnswer s result) [0 ..] (answerChoices q)
 
     statusBar =
         padLeftRight 1 $
-            hBox
-                [ str $ "Score: " ++ show (s ^. score) ++ "/" ++ show (s ^. currentIndex)
-                , str $ "  Time: " ++ formatTime (s ^. elapsedSeconds)
-                , fill ' '
-                , case s ^. phase of
-                    Answering ->
-                        clickable SubmitButton $
-                            withAttr submitAttr $
-                                str " [Enter] Submit "
-                    Reviewing ->
-                        clickable NextButton $
-                            withAttr nextAttr $
-                                str " [Enter] Next "
-                    Finished -> str ""
-                , fill ' '
-                , str "[q] Quit  [Space] Toggle  [Arrow Keys] Navigate"
-                ]
+            vLimitPercent 10 $
+                hBox
+                    [ str $ "Score: " ++ show (s ^. score) ++ "/" ++ show (totalQuestions s)
+                    , str $ "  Time: " ++ formatTime (s ^. elapsedSeconds)
+                    , fill ' '
+                    , case s ^. phase of
+                        Answering ->
+                            clickable SubmitButton $
+                                withAttr submitAttr $
+                                    str " [Enter] Submit "
+                        Reviewing ->
+                            clickable NextButton $
+                                withAttr nextAttr $
+                                    str " [Enter] Next "
+                        Finished -> str ""
+                    , fill ' '
+                    , str "[q] Quit  [Space] Toggle  [Arrow Keys] Navigate"
+                    ]
 
 drawAnswer :: AppState -> AnswerResult -> Int -> Text -> Widget Name
 drawAnswer s result idx answerText =
@@ -115,9 +113,9 @@ drawAnswer s result idx answerText =
   where
     selected = IS.member idx (s ^. selectedAnswers)
     focused = s ^. focusedAnswer == idx && s ^. phase == Answering
-    isCorrectSelection = IS.member idx (answerResultCorrect result)
-    isMissed = IS.member idx (answerResultMissing result)
-    isWrong = IS.member idx (answerResultWrong result)
+    isCorrectSelection = IS.member idx (correct result)
+    isMissed = IS.member idx (missing result)
+    isWrong = IS.member idx (wrong result)
 
     applyFocus w = if focused then withAttr focusedAttr w else w
 
@@ -142,4 +140,3 @@ drawAnswer s result idx answerText =
             | isWrong -> withAttr wrongAttr wrappedText
             | otherwise -> wrappedText
         _ -> wrappedText
-

app/TUI/Event.hs

@@ -18,28 +18,31 @@ import Types (Question (..), isCorrect)
 data CustomEvent = Tick
 
 handleEvent :: BrickEvent Name CustomEvent -> EventM Name AppState ()
-handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt
-handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
-handleEvent (VtyEvent (V.EvKey (V.KChar 'Q') [])) = halt
-handleEvent (VtyEvent (V.EvKey V.KEnter [])) = do
-    s <- get
-    case s ^. phase of
-        Answering -> submitAnswer
-        Reviewing -> nextQuestion
-        Finished -> halt
-handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) =
-    whenPhase Answering $ do
+handleEvent (VtyEvent (V.EvKey key [])) = case key of
+    V.KEsc -> halt
+    V.KChar 'q' -> halt
+    V.KChar 'Q' -> halt
+    V.KUp -> moveFocus (-1)
+    V.KChar 'k' -> moveFocus (-1)
+    V.KDown -> moveFocus 1
+    V.KChar 'j' -> moveFocus 1
+    V.KEnter -> do
+        s <- get
+        case s ^. phase of
+            Answering -> submitAnswer
+            Reviewing -> nextQuestion
+            Finished -> halt
+    V.KChar ' ' -> whenPhase Answering $ do
         mQ <- gets currentQuestion
         case mQ of
             Just q -> do
                 s <- get
-                let numAnswers = length (questionAnswerChoices q)
+                let numAnswers = length (answerChoices q)
                     idx = s ^. focusedAnswer
                 when (idx < numAnswers) $
                     selectedAnswers .= toggleAnswerPure idx (s ^. selectedAnswers)
             Nothing -> return ()
-handleEvent (VtyEvent (V.EvKey V.KUp [])) = moveFocus (-1)
-handleEvent (VtyEvent (V.EvKey V.KDown [])) = moveFocus 1
+    _ -> return ()
 handleEvent (MouseDown (AnswerChoice idx) _ _ _) =
     whenPhase Answering $ do
         sel <- use selectedAnswers
@@ -75,7 +78,7 @@ moveFocus delta =
         case mQ of
             Just q -> do
                 current <- use focusedAnswer
-                let numAnswers = length (questionAnswerChoices q)
+                let numAnswers = length (answerChoices q)
                 focusedAnswer .= moveFocusPure delta current numAnswers
             Nothing -> return ()
 

cert-prep.cabal

@@ -14,6 +14,7 @@ build-type:         Simple
 
 library
     exposed-modules:
+        Registry
         Sampling
         Types
         Util
@@ -22,9 +23,13 @@ library
     build-depends:
         aeson,
         base <5,
+        bytestring,
         containers,
+        directory,
+        filepath,
         random,
-        text
+        text,
+        time
     hs-source-dirs:
         src
     default-extensions:
@@ -38,6 +43,7 @@ executable cert-prep
         CLI
         State
         TUI.Attributes
+        TUI.ConfigSelect
         TUI.Draw
         TUI.Event
         Paths_cert_prep
@@ -54,6 +60,7 @@ executable cert-prep
         optparse-applicative,
         random,
         text,
+        time,
         vector,
         vty,
         vty-crossplatform
@@ -74,6 +81,7 @@ test-suite spec
         StateSpec
         UtilSpec
         EventSpec
+        RegistrySpec
         State
         TUI.Event
     hs-source-dirs:
@@ -89,14 +97,18 @@ test-suite spec
         aeson,
         base <5,
         brick,
+        bytestring,
         cert-prep,
         containers,
+        directory,
         hspec,
         microlens,
         microlens-mtl,
         microlens-th,
         random,
+        temporary,
         text,
+        time,
         vector,
         vty
     default-language: GHC2021