From 59c8620cdd3b2839648288e89c5d6c25eae563d7 Mon Sep 17 00:00:00 2001 From: Saad Rhoulam Date: Thu, 22 Jul 2021 20:58:34 -0400 Subject: [PATCH] WIP. Create and delete decks, with database persistence. --- babel-cards.cabal | 4 +- package.yaml | 2 + src/Application/Database.hs | 3 +- src/Application/TUI.hs | 261 +++++++++++++++++++++--------------- src/Import/Main.hs | 4 +- src/Model.hs | 10 +- src/Types/TUI.hs | 35 +++-- stack.yaml | 2 +- 8 files changed, 189 insertions(+), 132 deletions(-) diff --git a/babel-cards.cabal b/babel-cards.cabal index ed8c001..0fc554a 100644 --- a/babel-cards.cabal +++ b/babel-cards.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4fde194f696b0b94c80772e3e95c24155b2e91b943887cc178cbf7ef67ade9d4 +-- hash: 74ff7ad6298c7bc5c792db969bc8935ed56c223f2144585438870cbdc7231c17 name: babel-cards version: 0.1.0 @@ -61,6 +61,8 @@ library , esqueleto , file-embed , filepath + , interpolate + , microlens , microlens-th , monad-logger , persistent diff --git a/package.yaml b/package.yaml index eca17fe..fdd808b 100644 --- a/package.yaml +++ b/package.yaml @@ -57,6 +57,8 @@ library: - esqueleto - file-embed - filepath + - interpolate + - microlens - microlens-th - monad-logger - persistent diff --git a/src/Application/Database.hs b/src/Application/Database.hs index 82653da..8c6502d 100644 --- a/src/Application/Database.hs +++ b/src/Application/Database.hs @@ -7,6 +7,7 @@ import qualified Database.Esqueleto as E import Database.Persist as Application.Database -- import Database.Persist.Class as Application.Database import Database.Persist.Sql (SqlBackend, runSqlPool) +-- import Lens.Micro import Model as Application.Database import RIO import RIO.List (headMaybe) @@ -80,7 +81,7 @@ retrieveDeckSummaries = do ) return $ mkDeckMetadata <$> summaries - where mkDeckMetadata (dmDeckEntity, E.Value dmLastStudied, E.Value dmCardCount) = + where mkDeckMetadata (_deckEntity, E.Value _lastStudied, E.Value _cardCount) = DeckMetadata {..} retrieveNextCard :: DeckId -> BabelQuery (Maybe (Entity Card)) diff --git a/src/Application/TUI.hs b/src/Application/TUI.hs index 304637a..02cf486 100644 --- a/src/Application/TUI.hs +++ b/src/Application/TUI.hs @@ -1,33 +1,39 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Application.TUI where import Application.Database import Brick import Brick.BChan -import Brick.Forms (checkboxField, editTextField, (@@=), - formState, handleFormEvent, - newForm, renderForm) +import Brick.Forms (checkboxField, editTextField, + formState, handleFormEvent, + newForm, renderForm, (@@=)) import Brick.Main -import Brick.Widgets.Border (border, borderWithLabel, hBorder, - hBorderWithLabel) -import Brick.Widgets.Border.Style (unicode) -import Brick.Widgets.Center (hCenter, vCenter) -import Brick.Widgets.Dialog (dialog) -import Brick.Widgets.Edit (Editor, editor, handleEditorEvent, - renderEditor) +import Brick.Widgets.Border (border, borderWithLabel, + hBorder, hBorderWithLabel) +import Brick.Widgets.Border.Style (unicode) +import Brick.Widgets.Center (hCenter, vCenter) +import Brick.Widgets.Dialog (dialog) +import Brick.Widgets.Edit (Editor, editor, + handleEditorEvent, + renderEditor) import Brick.Widgets.List -- listSelectedElement, renderList) -import qualified Data.Sequence as Seq (fromList, singleton) -import qualified Data.Text as Text (unpack) -import qualified Graphics.Vty (defaultConfig, mkVty) +import qualified Data.Sequence as Seq (filter, fromList, + singleton, (|>)) +import Data.String.Interpolate.IsString +import qualified Data.Text as Text (unpack) +import qualified Graphics.Vty (defaultConfig, mkVty) import Graphics.Vty.Attributes import Graphics.Vty.Input.Events +import Lens.Micro import Model -import RIO -import RIO.List (headMaybe) +import RIO hiding (view) +import RIO.List (headMaybe) import RIO.Time +import Text.Printf import Types import Types.TUI @@ -47,87 +53,117 @@ lifecycle = do , (listSelectedAttr, withStyle currentAttr bold) , (listSelectedFocusedAttr, withStyle currentAttr $ bold + standout) ] - appStartEvent st@BabelTUI {..} = do - availDecks <- runRIO btBabel $ runDB $ retrieveDeckSummaries - -- TODO: load modes, when lua scripting is implemented - return st - { btAvailableDecks = - list "availableDecks" (Seq.fromList availDecks) 1 - , btAvailableModes = - list "availableModes" (Seq.singleton Standard) 1 - } - appChooseCursor = showFirstCursor + appStartEvent st = do + availDecks <- runRIO (st ^. babel) $ runDB $ retrieveDeckSummaries + -- TODO: load modes, when lua scripting is implemented + return + $ st + & availableDecks .~ list "availableDecks" (Seq.fromList availDecks) 1 + & availableModes .~ list "availableModes" (Seq.singleton Standard) 1 - appHandleEvent st@BabelTUI {..} evt = do + appHandleEvent st evt = do case evt of AppEvent appEvent -> case appEvent of - CreateDeck deck -> error "create deck" - -- TODO: insert deck into db! - -- TODO: add new deck to available decks - _ -> return () - - case btView of - Start -> case evt of - VtyEvent event -> do - updatedList <- handleListEvent event btStartOptions - let newState = st { btStartOptions = updatedList } + CreateDeck deck -> do + deckId <- liftIO $ runRIO (st ^. babel) $ runDB $ insert deck + continue $ st + & availableDecks . listElementsL + %~ (Seq.|> newDeckMetadata (Entity deckId deck)) + DeleteDeck deckId -> do + liftIO $ runRIO (st ^. babel) $ runDB $ delete deckId + continue $ st + & availableDecks . listElementsL + %~ Seq.filter ((deckId /=) . (^. deckEntity . key)) + + VtyEvent event -> case st ^. view of + Start -> do + updatedList <- handleListEvent event $ st ^. startOptions + let newState = st & startOptions .~ updatedList case event of EvKey (KChar 'q') [] -> halt newState - EvKey KEnter [] -> continue newState - { btView = maybe btView (fst . snd) - $ listSelectedElement updatedList - } + EvKey KEnter [] -> continue $ newState + & view + .~ maybe (st ^. view) (fst . snd) (listSelectedElement updatedList) + _ -> continue newState + + DeckSelect -> continue st + ModeSelect -> continue st + + AddNewDeck -> do + updatedForm <- handleFormEvent evt $ st ^. deckForm + let newState = st & deckForm .~ updatedForm + case event of + EvKey KEsc [] -> + continue $ newState & view .~ DecksOverview False + EvKey (KChar 'd') [MCtrl] -> do + liftIO $ writeBChan (st ^. chan) $ CreateDeck $ formState updatedForm + continue $ newState & view .~ DecksOverview False + _ -> continue newState + + DecksOverview True -> do + updatedForm <- handleFormEvent evt $ st ^. answerForm + + let newState = st & answerForm .~ updatedForm + userInput = formState updatedForm + + case event of + EvKey KEsc [] -> continue $ newState & view .~ DecksOverview False + EvKey KEnter [] -> do + let mayDeckName = st ^? activeDeck . _Just . val . name + mayDeckId = st ^? activeDeck . _Just . key + + case (Just userInput == mayDeckName, mayDeckId) of + (True, Just deckId) -> do + liftIO $ writeBChan (st ^. chan) + $ DeleteDeck deckId + continue $ newState + & activeDeck .~ Nothing + & view .~ DecksOverview False + _ -> continue newState _ -> continue newState - _ -> continue st - - DeckSelect -> case evt of - _ -> continue st - - ModeSelect -> case evt of - _ -> continue st - - AddNewDeck -> do - updatedForm <- handleFormEvent evt btDeckForm - case evt of - VtyEvent event -> do - let newState = st { btDeckForm = updatedForm } - case event of - EvKey KEsc [] -> continue newState - { btView = DecksOverview } - EvKey (KChar 'd') [MCtrl] -> do - liftIO $ writeBChan btChan $ CreateDeck $ formState updatedForm - continue newState { btView = DeckManagement } - _ -> continue newState - _ -> continue st - - DecksOverview -> case evt of - VtyEvent event -> do - updatedList <- handleListEvent event btAvailableDecks - let newState = st { btAvailableDecks = updatedList } + + DecksOverview False -> do + updatedList <- handleListEvent event $ st ^. availableDecks + let newState = st & availableDecks .~ updatedList + selectedDeck = _deckEntity . snd <$> listSelectedElement updatedList case event of - EvKey KEsc [] -> continue newState - { btView = Start - } - EvKey KEnter [] -> continue newState - { btView = DeckManagement - , btActiveDeck = dmDeckEntity . snd <$> listSelectedElement updatedList - } - EvKey (KChar 'a') [] -> continue newState - { btView = AddNewDeck - } + EvKey KEsc [] -> continue $ newState & view .~ Start + EvKey KEnter [] -> continue $ newState + & view .~ DeckManagement + & activeDeck .~ selectedDeck + + EvKey (KChar 'a') [] -> continue $ newState + & view .~ AddNewDeck + & deckForm .~ deckForm' + EvKey KDel [] -> continue $ newState + & activeDeck .~ selectedDeck + & view .~ DecksOverview True + & answerForm .~ answerForm' _ -> continue newState - _ -> continue st + _ -> continue st - appDraw BabelTUI {..} = catMaybes - [ Just $ case btView of + appDraw st = catMaybes + [ case st ^. view of + DecksOverview deleting -> do + guard deleting + Entity _ deck <- st ^. activeDeck + return $ vCenter + $ borderWithLabel (str "Delete Deck") + $ vBox + [ hCenter $ strWrap [i|To confirm deletion, write '#{deck ^. name}' in the box below and press ENTER. This cannot be undone. To cancel, press ESC.|] + , hCenter $ border $ renderForm $ st ^. answerForm + ] + _ -> Nothing + + , Just $ case st ^. view of Start -> applicationTitle $ vBox [ hCenter $ strWrap "A flash-cards memorization tool." , hBorder , vCenter $ vBox - [ renderList renderStartOption True btStartOptions + [ renderList renderStartOption True $ st ^. startOptions , hCenter (strWrap "Press ENTER to make a selection.") , hCenter (strWrap "Press Q to quit.") ] @@ -151,19 +187,20 @@ lifecycle = do AddNewDeck -> applicationTitle $ vBox [ hBorderWithLabel (str "Add New Deck") - , vCenter $ renderForm btDeckForm + , vCenter $ renderForm $ st ^. deckForm , hCenter $ strWrap "Press TAB to proceed to the next field." , hCenter $ strWrap "Press Shift+TAB to return to a previous field." , hCenter $ strWrap "Press Ctrl+D when finished." ] - DecksOverview -> applicationTitle + DecksOverview _ -> applicationTitle $ vBox [ hBorderWithLabel (str "Decks") , vCenter $ vBox - [ renderList renderDeckMenuOption True btAvailableDecks + [ hCenter $ renderList renderDeckMenuOption True $ st ^. availableDecks , hCenter (strWrap "Press ENTER to make a selection.") , hCenter (strWrap "Press A to add a new deck.") + , hCenter (strWrap "Press DEL to delete the selected deck.") , hCenter (strWrap "Press ESC to return.") ] ] @@ -177,14 +214,12 @@ lifecycle = do Credits -> error "Credits" ] - renderDeckMenuOption _ DeckMetadata {..} = - let Entity _ deck = dmDeckEntity - in hBox - [ str (Text.unpack $ deckName deck) - , str $ show dmCardCount - , str $ maybe "Never" (formatTime defaultTimeLocale "%_Y-%m-%d %T") dmLastStudied - ] - <=> strWrap (Text.unpack $ deckDescription deck) + renderDeckMenuOption _ dm = hBox + [ padRight Max $ str $ Text.unpack $ dm ^. deckEntity . val . name + , str $ printf "%7d" $ dm ^. cardCount + , padLeft Max $ str $ maybe "Never" (formatTime defaultTimeLocale "%_Y-%m-%d %T") $ dm ^. lastStudied + ] + <=> strWrap (Text.unpack $ dm ^. deckEntity . val . description) renderStartOption _ (_, label) = hCenter $ strWrap label @@ -192,50 +227,56 @@ lifecycle = do applicationTitle = borderWithLabel (str "BabelCards") initialState env chan = BabelTUI - { btBabel = env - , btView = Start - , btChan = chan + { _babel = env + , _view = Start + , _chan = chan - , btActiveCard = Nothing - , btActiveDeck = Nothing + , _activeCard = Nothing + , _activeDeck = Nothing - , btAnswerForm = answerForm - , btCardForm = cardForm - , btDeckForm = deckForm + , _answerForm = answerForm' + , _cardForm = cardForm' + , _deckForm = deckForm' - , btAvailableDecks = list "availableDecks" mempty 1 - , btAvailableModes = list "availableModes" mempty 1 - , btStartOptions = list "startOptions" + , _availableDecks = list "availableDecks" mempty 1 + , _availableModes = list "availableModes" mempty 1 + , _startOptions = list "startOptions" (Seq.fromList [ (DeckSelect, "Study a Deck") - , (DecksOverview, "Decks") + , (DecksOverview False, "Decks") , (CardsOverview, "Cards") , (Credits, "About") ]) 1 } - answerForm = newForm + answerForm' = newForm [ editTextField id "userEntry" (Just 1) ] mempty - cardForm = newForm - [ (str "Obverse: " <+>) + cardForm' = newForm -- TODO: pad? + [ (padRight (Pad 1) (str "Obverse:") <+>) @@= editTextField obverse "cardObverse" (Just 1) - , (str "Reverse: " <+>) + , (padRight (Pad 1) (str "Reverse:") <+>) @@= editTextField Model.reverse "cardReverse" (Just 1) -- , checkboxField enabled "cardEnabled" "Enabled" ] (Card "" "" True) - deckForm = newForm - [ (str "Name: " <+>) + deckForm' = newForm + [ (padRight (Pad 8) (str "Name:") <+>) @@= editTextField name "deckName" (Just 1) - , (str "Description: " <+>) + , (padRight (Pad 1) (str "Description:") <+>) @@= editTextField description "deckDescription" Nothing ] (Deck "" "") + newDeckMetadata de = DeckMetadata + { _deckEntity = de + , _cardCount = 0 + , _lastStudied = Nothing + } + copyrightNotice = vBox $ hCenter <$> [ strWrap "BabelCards v0.1.0" diff --git a/src/Import/Main.hs b/src/Import/Main.hs index 40d58f0..2d5e397 100644 --- a/src/Import/Main.hs +++ b/src/Import/Main.hs @@ -1,6 +1,6 @@ module Import.Main (module Import.Main) where -import Control.Monad.Logger (runStderrLoggingT) +import Control.Monad.Logger (runNoLoggingT) import Database.Persist.Sql (ConnectionPool) import Database.Persist.Sqlite (SqliteConf (..), createSqlitePool, createSqlitePoolFromInfo, @@ -17,7 +17,7 @@ import Util.String (mapText) createConnPool :: BabelEmbeddedSettings -> IO ConnectionPool createConnPool settings = do dataDir <- ensureDataDirExists settings - runStderrLoggingT $ case besDatabase settings of + runNoLoggingT $ case besDatabase settings of SqliteConf connStr poolSize -> createSqlitePool (mapText (dataDir ) connStr) poolSize SqliteConfInfo confInfo poolSize -> createSqlitePoolFromInfo diff --git a/src/Model.hs b/src/Model.hs index 4246d12..6184ef7 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -36,7 +35,10 @@ makeLensesWith camelCaseFields ''Card makeLensesWith camelCaseFields ''Deck data DeckMetadata = DeckMetadata - { dmDeckEntity :: !(Entity Deck) - , dmCardCount :: !Int - , dmLastStudied :: !(Maybe UTCTime) + { _deckEntity :: !(Entity Deck) + , _cardCount :: !Int + , _lastStudied :: !(Maybe UTCTime) } + +makeLenses ''DeckMetadata +makeLensesWith camelCaseFields ''Entity diff --git a/src/Types/TUI.hs b/src/Types/TUI.hs index 616a090..4343985 100644 --- a/src/Types/TUI.hs +++ b/src/Types/TUI.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} module Types.TUI where import Brick.BChan (BChan) @@ -7,30 +10,33 @@ import Brick.Widgets.List (GenericList) import Data.Sequence (Seq) import Data.Text (Text) import Database.Persist.Types (Entity) +import Lens.Micro.TH import Model import RIO import Types data BabelTUI = BabelTUI - { btBabel :: !Babel - , btView :: !BabelView - , btChan :: !(BChan BabelEvent) + { _babel :: !Babel + , _view :: !BabelView + , _chan :: !(BChan BabelEvent) - , btActiveCard :: !(Maybe (Entity Card)) - , btActiveDeck :: !(Maybe (Entity Deck)) + , _activeCard :: !(Maybe (Entity Card)) + , _activeDeck :: !(Maybe (Entity Deck)) - , btAnswerForm :: !(Form Text BabelEvent String) - , btCardForm :: !(Form Card BabelEvent String) - , btDeckForm :: !(Form Deck BabelEvent String) + , _answerForm :: !(Form Text BabelEvent String) + , _cardForm :: !(Form Card BabelEvent String) + , _deckForm :: !(Form Deck BabelEvent String) - --, btAvailableCards - , btAvailableDecks :: !(GenericList String Seq DeckMetadata) - , btAvailableModes :: !(GenericList String Seq BabelMode) - , btStartOptions :: !(GenericList String Seq (BabelView, String)) + --, _availableCards + , _availableDecks :: !(GenericList String Seq DeckMetadata) + , _availableModes :: !(GenericList String Seq BabelMode) + , _startOptions :: !(GenericList String Seq (BabelView, String)) } + data BabelEvent = CreateDeck Deck + | DeleteDeck DeckId -- TODO: Care will have to -- be taken in designing this type, as it will be @@ -52,6 +58,9 @@ data BabelView = | AddNewDeck | DecksOverview + Bool -- ^ Deleting the active deck? | DeckManagement | Credits + +makeLenses ''BabelTUI diff --git a/stack.yaml b/stack.yaml index c53cb08..7529666 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,7 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {}