Implement card editing.

Also rename the fields on Babel object and preserve lens names.
srhoulam · May 4, 2022 · 93ed64c · 93ed64c
1 parent 6dcd7ae
commit 93ed64c
Show file tree

Hide file tree

Showing 4 changed files with 115 additions and 58 deletions.
diff --git a/src/Application/Database.hs b/src/Application/Database.hs
@@ -59,11 +59,11 @@ unassignCardTag tagId' cardId' = do
     lift $ delete dmid
   return ()
 
-createCard :: NewCard -> BabelQuery CardId
-createCard NewCard {..} = do
-  newCardId <- insert $ Card newCardObverse newCardReverse True
+createCard :: CardFormState -> BabelQuery CardId
+createCard CardFormState {..} = do
+  newCardId <- insert $ Card cardFormStateObverse cardFormStateReverse True
 
-  let tagNames = sort $ Text.lines newCardTags
+  let tagNames = sort $ Text.lines cardFormStateTags
   existingTags <- selectList [ TagName <-. tagNames] [ Asc TagName ]
   let nonExistingTags = tagNames \\ existingTags ^.. each . val . name
       existingTagIds = existingTags ^.. each . key

diff --git a/src/Application/TUI.hs b/src/Application/TUI.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeFamilies      #-}
 module Application.TUI where
 
 import           Application.Database             as DB
@@ -87,6 +89,13 @@ lifecycle = do
               runRIO (st ^. babel) $ runDB $ update cardId' [ CardEnabled =. False ]
               continue st
 
+            EditCard cardId' cardFormState -> do
+              runRIO (st ^. babel) $ runDB $ update cardId'
+                [ CardObverse =. cardFormState ^. obverse
+                , CardReverse =. cardFormState ^. reverse
+                ]
+              continue st
+
             EnableCard cardId' -> do
               runRIO (st ^. babel) $ runDB $ update cardId' [ CardEnabled =. True ]
               continue st
@@ -159,7 +168,16 @@ lifecycle = do
                   continue newState
                 EvKey (KChar 'a') [] -> continue $ newState
                   & view .~ AddNewCard
-                  & cardForm .~ cardForm'
+                  & cardForm .~ newCardForm'
+                EvKey (KChar 'e') [] -> do
+                  let selectedCardMay' = selectedCardId
+                        >>= (IntMap.!?) (st ^. cardMapEnabled) . keyToInt
+                  cardMay <- forM selectedCardMay' $ return . entityVal
+                  case cardMay of
+                    Just card -> continue $ newState
+                      & view .~ CardManagement
+                      & cardForm .~ editCardForm' (card ^. obverse) (card ^. reverse)
+                    Nothing -> continue newState
                 EvKey (KChar 'd') [] -> do
                   _ <- liftIO $ runMaybeT $ do
                     sdid <- MaybeT $ return selectedDeckId
@@ -251,6 +269,26 @@ lifecycle = do
                   & answerForm .~ answerForm'
                 _ -> continue newState
 
+            CardManagement -> do
+              updatedForm <- handleFormEvent evt $ st ^. cardForm
+              let newState = st & cardForm .~ updatedForm
+                  selectedCardIdMay = listSelectedElement (st ^. availableCardsEnabled)
+
+              case event of
+                EvKey KEsc [] ->
+                  continue $ newState & view .~ CardsOverview
+                EvKey (KChar 'd') [MCtrl] -> do
+                  liftIO $ forM_ selectedCardIdMay $ \(_, selectedCardId) -> do
+                    writeBChan (newState ^. chan)
+                      $ EditCard selectedCardId (formState updatedForm)
+                    writeBChan (newState ^. chan) LoadTags
+                    writeBChan (newState ^. chan) LoadCards
+                    writeBChan (newState ^. chan) LoadCurrCardMd
+                  continue $ newState
+                    & view .~ CardsOverview
+                    & cardForm .~ newCardForm'
+                _ -> continue newState
+
             DeckManagement -> do
               updatedAvailCardsEnabled <- handleListEvent event $ st ^. availableCardsEnabled
 
@@ -518,6 +556,15 @@ lifecycle = do
                   ]
                 ]
 
+              CardManagement -> applicationTitle
+                $ vBox
+                [ hBorderWithLabel (str "Edit Card")
+                , vCenter $ renderForm $ st ^. cardForm
+                , 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."
+                ]
+
               DeckManagement ->
                 let selectedDeckId = fromJust $ snd
                       <$> listSelectedElement (st ^. availableDecks)
@@ -692,33 +739,33 @@ lifecycle = do
         applicationTitle = borderWithLabel (str "BabelCards")
 
         initialState env chan' = BabelTUI
-          { _babel = env
-          , _view = Start
-          , _chan = chan'
+          { babelTUIBabel = env
+          , babelTUIView = Start
+          , babelTUIChan = chan'
 
-          , _gameState = Nothing
+          , babelTUIGameState = Nothing
 
-          , _focusX = 0
-          , _focusY = 0
+          , babelTUIFocusX = 0
+          , babelTUIFocusY = 0
 
-          , _cardMapEnabled = mempty
-          , _cardMapDisabled = mempty
-          , _deckMap = mempty
-          , _tagMap  = mempty
+          , babelTUICardMapEnabled = mempty
+          , babelTUICardMapDisabled = mempty
+          , babelTUIDeckMap = mempty
+          , babelTUITagMap  = mempty
 
-          , _answerForm = answerForm'
-          , _cardForm = cardForm'
-          , _deckForm = deckForm'
+          , babelTUIAnswerForm = answerForm'
+          , babelTUICardForm = newCardForm'
+          , babelTUIDeckForm = deckForm'
 
-          , _activeCardDecks = list "activeCardDecks" mempty 1
-          , _activeCardTags = list "activeCardTags" mempty 1
+          , babelTUIActiveCardDecks = list "activeCardDecks" mempty 1
+          , babelTUIActiveCardTags = list "activeCardTags" mempty 1
 
-          , _availableCardsEnabled = list "availableCardsEnabled" mempty 1
-          , _availableCardsDisabled = list "availableCardsDisabled" mempty 1
-          , _availableDecks = list "availableDecks" mempty 1
-          , _availableModes = list "availableModes" mempty 1
-          , _availableTags  = list "availableTags"  mempty 1
-          , _startOptions = list "startOptions"
+          , babelTUIAvailableCardsEnabled = list "availableCardsEnabled" mempty 1
+          , babelTUIAvailableCardsDisabled = list "availableCardsDisabled" mempty 1
+          , babelTUIAvailableDecks = list "availableDecks" mempty 1
+          , babelTUIAvailableModes = list "availableModes" mempty 1
+          , babelTUIAvailableTags  = list "availableTags"  mempty 1
+          , babelTUIStartOptions = list "startOptions"
               (Seq.fromList
                [ (DeckSelect, "Study a Deck")
                , (CardsOverview, "Cards")
@@ -733,15 +780,23 @@ lifecycle = do
           [ editTextField id "userEntry" (Just 1) ]
           mempty
 
-        cardForm' = newForm
+        editCardForm' obverse' reverse' = newForm
+          [ (padRight (Pad 1) (str "Obverse:") <+>)
+            @@= editTextField obverse "cardObverse" (Just 1)
+          , (padRight (Pad 1) (str "Reverse:") <+>)
+            @@= editTextField reverse "cardReverse" (Just 1)
+          ]
+          (CardFormState obverse' reverse' "")
+
+        newCardForm' = newForm
           [ (padRight (Pad 1) (str "Obverse:") <+>)
             @@= editTextField obverse "cardObverse" (Just 1)
           , (padRight (Pad 1) (str "Reverse:") <+>)
             @@= editTextField reverse "cardReverse" (Just 1)
           , (padRight (Pad 4) (str "Tags:") <+>)
             @@= editTextField tags "cardTagList" Nothing
           ]
-          (NewCard "" "" "")
+          (CardFormState "" "" "")
 
         deckForm' = newForm
           [ (padRight (Pad 8) (str "Name:") <+>)
@@ -1198,7 +1253,7 @@ lifecycle = do
         copyrightNotice = vBox
           $ hCenter <$>
           [ strWrap "BabelCards v0.1.0"
-          , strWrap "Copyright (c) 2021 Saad Rhoulam"
+          , strWrap "Copyright (c) 2021-2022 Saad Rhoulam"
           , strWrap "BabelCards comes with ABSOLUTELY NO WARRANTY."
           , strWrap "BabelCards is distributed under the GPLv3 license."
           ]
diff --git a/src/Model.hs b/src/Model.hs
@@ -17,7 +17,7 @@ module Model where
 
 import           Database.Persist.Class (ToBackendKey)
 import           Database.Persist.Quasi (lowerCaseSettings)
-import           Database.Persist.Sql   (Key, SqlBackend, fromSqlKey)
+import           Database.Persist.Sql   (Key, SqlBackend, fromSqlKey, toSqlKey)
 import           Database.Persist.TH
 import           Database.Persist.Types (Entity)
 import           Lens.Micro.TH

diff --git a/src/Types/TUI.hs b/src/Types/TUI.hs
@@ -18,43 +18,43 @@ import           RIO                    hiding (view)
 import           Types
 
 data BabelTUI = BabelTUI
-  { _babel                  :: !Babel
-  , _view                   :: !BabelView
-  , _chan                   :: !(BChan BabelEvent)
+  { babelTUIBabel                  :: !Babel
+  , babelTUIView                   :: !BabelView
+  , babelTUIChan                   :: !(BChan BabelEvent)
 
-  , _gameState              :: !(Maybe GameState)
+  , babelTUIGameState              :: !(Maybe GameState)
 
-  , _focusX                 :: !Int
+  , babelTUIFocusX                 :: !Int
   -- ^ Left-to-right focus.
   -- Each view will set and interpret this as it will.
   -- Setting min/max bounds during view transitions is
   -- advised.
-  , _focusY                 :: !Int
+  , babelTUIFocusY                 :: !Int
   -- ^ Top-to-bottom focus.
   -- Each view will set and interpret this as it will.
   -- Setting min/max bounds during view transitions is
   -- advised.
 
-  , _cardMapEnabled         :: !(IntMap (Entity Card))
-  , _cardMapDisabled        :: !(IntMap (Entity Card))
-  , _deckMap                :: !(IntMap DeckMetadata)
-  , _tagMap                 :: !(IntMap (Entity Tag))
+  , babelTUICardMapEnabled         :: !(IntMap (Entity Card))
+  , babelTUICardMapDisabled        :: !(IntMap (Entity Card))
+  , babelTUIDeckMap                :: !(IntMap DeckMetadata)
+  , babelTUITagMap                 :: !(IntMap (Entity Tag))
 
-  , _answerForm             :: !(Form Text BabelEvent String)
-  , _cardForm               :: !(Form NewCard BabelEvent String)
-  , _deckForm               :: !(Form Deck BabelEvent String)
+  , babelTUIAnswerForm             :: !(Form Text BabelEvent String)
+  , babelTUICardForm               :: !(Form CardFormState BabelEvent String)
+  , babelTUIDeckForm               :: !(Form Deck BabelEvent String)
 
   -- Display lists
-  , _activeCardDecks        :: !(GenericList String Seq DeckId)
-  , _activeCardTags         :: !(GenericList String Seq TagId)
+  , babelTUIActiveCardDecks        :: !(GenericList String Seq DeckId)
+  , babelTUIActiveCardTags         :: !(GenericList String Seq TagId)
 
   -- Interactive lists
-  , _availableCardsEnabled  :: !(GenericList String Seq CardId)
-  , _availableCardsDisabled :: !(GenericList String Seq CardId)
-  , _availableDecks         :: !(GenericList String Seq DeckId)
-  , _availableModes         :: !(GenericList String Seq BabelMode)
-  , _availableTags          :: !(GenericList String Seq TagId)
-  , _startOptions           :: !(GenericList String Seq (BabelView, String))
+  , babelTUIAvailableCardsEnabled  :: !(GenericList String Seq CardId)
+  , babelTUIAvailableCardsDisabled :: !(GenericList String Seq CardId)
+  , babelTUIAvailableDecks         :: !(GenericList String Seq DeckId)
+  , babelTUIAvailableModes         :: !(GenericList String Seq BabelMode)
+  , babelTUIAvailableTags          :: !(GenericList String Seq TagId)
+  , babelTUIStartOptions           :: !(GenericList String Seq (BabelView, String))
   }
 
 
@@ -63,7 +63,8 @@ data BabelEvent =
   | UnassignCardDeck DeckId CardId
   | AssignCardTag TagId CardId
   | UnassignCardTag TagId CardId
-  | CreateCard NewCard
+  | CreateCard CardFormState
+  | EditCard CardId CardFormState
   | DisableCard CardId
   | EnableCard CardId
 
@@ -113,6 +114,7 @@ data BabelView =
   | AddNewCard
   | CardsOverview
   | CardsOverviewDisabled
+  | CardManagement
 
   | AddNewDeck
   | DecksOverview
@@ -142,22 +144,22 @@ data GameState = GameState
   , gameStateMessagesStack :: ![String]
   }
 
-data NewCard = NewCard
-  { newCardObverse :: Text
-  , newCardReverse :: Text
-  , newCardTags    :: Text
+data CardFormState = CardFormState
+  { cardFormStateObverse :: Text
+  , cardFormStateReverse :: Text
+  , cardFormStateTags    :: Text
   }
 
 data UserInput =
   TextInput Text
   | CardChoice CardId
   | TagChoice TagId
 
-makeFields ''NewCard
+makeFields ''CardFormState
 makeFields ''CardMetadata
 makeFields ''DeckMetadata
 makeFields ''GameState
-makeLenses ''BabelTUI
+makeFields ''BabelTUI
 
 -- emptyGameState :: GameState
 -- emptyGameState = GameState