diff --git a/src/Application/Database.hs b/src/Application/Database.hs index 4f7b6b8..cbdbc42 100644 --- a/src/Application/Database.hs +++ b/src/Application/Database.hs @@ -36,6 +36,14 @@ assignCardDeck deckId' cardId' = do return () +assignCardTag :: TagId -> CardId -> BabelQuery () +assignCardTag tagId' cardId' = do + _ <- runMaybeT + $ void (MaybeT $ getBy $ UniqueTagCard tagId' cardId') + <|> lift (insert_ $ TagMember tagId' cardId') + + return () + unassignCardDeck :: DeckId -> CardId -> BabelQuery () unassignCardDeck deckId' cardId' = do for_ [minBound..maxBound] $ \qi -> runMaybeT $ do @@ -46,6 +54,13 @@ unassignCardDeck deckId' cardId' = do lift $ delete dmid return () +unassignCardTag :: TagId -> CardId -> BabelQuery () +unassignCardTag tagId' cardId' = do + _ <- runMaybeT $ do + Entity dmid _ <- MaybeT $ getBy $ UniqueTagCard tagId' cardId' + lift $ delete dmid + return () + createCard :: NewCard -> BabelQuery CardId createCard NewCard {..} = do newCardId <- insert $ Card newCardObverse newCardReverse True @@ -101,8 +116,23 @@ retrieveCardTags :: CardId -> BabelQuery [TagId] retrieveCardTags cardId' = fmap (^. val . tagId) <$> selectList [ TagMemberCardId ==. cardId' ] [ Asc TagMemberTagId ] -retrieveCards :: BabelQuery [Entity Card] -retrieveCards = +retrieveCardsDisabled :: BabelQuery [Entity Card] +retrieveCardsDisabled = + E.select $ E.from $ \(card `E.LeftOuterJoin` tm `E.LeftOuterJoin` dm) -> do + E.on $ card E.^. CardId E.==. dm E.^. DeckMemberCardId + E.on $ card E.^. CardId E.==. tm E.^. TagMemberCardId + + E.groupBy $ card E.^. CardId + let numDecks = E.countDistinct $ dm E.^. DeckMemberId :: E.SqlExpr (E.Value Int) + numTags = E.countDistinct $ tm E.^. TagMemberId :: E.SqlExpr (E.Value Int) + E.where_ $ E.not_ $ card E.^. CardEnabled + E.orderBy [ E.asc numDecks + , E.asc numTags + ] + return card + +retrieveCardsEnabled :: BabelQuery [Entity Card] +retrieveCardsEnabled = E.select $ E.from $ \(card `E.LeftOuterJoin` tm `E.LeftOuterJoin` dm) -> do E.on $ card E.^. CardId E.==. dm E.^. DeckMemberCardId E.on $ card E.^. CardId E.==. tm E.^. TagMemberCardId @@ -113,7 +143,6 @@ retrieveCards = E.where_ $ card E.^. CardEnabled E.orderBy [ E.asc numDecks , E.asc numTags - -- , E.desc $ card E.^. CardEnabled ] return card diff --git a/src/Application/TUI.hs b/src/Application/TUI.hs index 94faae9..b75cfe6 100644 --- a/src/Application/TUI.hs +++ b/src/Application/TUI.hs @@ -56,106 +56,60 @@ lifecycle = do , (listSelectedFocusedAttr, withStyle currentAttr $ bold + standout) ] appChooseCursor = showFirstCursor - appStartEvent st = do - (availCards, availDecks, availTags) <- runRIO (st ^. babel) $ runDB $ do - availCards <- retrieveCards - availDecks <- retrieveDeckSummaries - availTags <- retrieveTags - return (availCards, availDecks, availTags) - -- TODO: load modes, when lua scripting is implemented - let dmap = IntMap.fromList - $ (\dm -> (keyToInt $ dm ^. deckEntity . key, dm)) - <$> availDecks - deckIds = (^. deckEntity . key) <$> availDecks - cmap = IntMap.fromList - $ (\ce -> (keyToInt $ ce ^. key, ce)) - <$> availCards - cardIds = (^. key) <$> availCards - tmap = IntMap.fromList - $ (\te -> (keyToInt $ te ^. key, te)) - <$> availTags - tagIds = (^. key) <$> availTags - return - $ st - & cardMap .~ cmap - & deckMap .~ dmap - & tagMap .~ tmap - & availableCards .~ list "availableCards" (Seq.fromList cardIds) 1 - & availableDecks .~ list "availableDecks" (Seq.fromList deckIds) 1 - & availableModes .~ list "availableModes" (Seq.singleton Standard) 1 - & availableTags .~ list "availableTags" (Seq.fromList tagIds) 1 + + appStartEvent = loadModes >=> loadDecks >=> loadTags >=> loadCards appHandleEvent st evt = do case evt of AppEvent appEvent -> case appEvent of AssignCardDeck deckId' cardId' -> do - liftIO $ do - runRIO (st ^. babel) $ runDB $ assignCardDeck deckId' cardId' - -- writeBChan (st ^. chan) $ LoadCard cardId' - -- continue st - st1 <- reloadCards st >>= reloadTags - loadCurrCardMd st1 >>= continue + runRIO (st ^. babel) $ runDB $ assignCardDeck deckId' cardId' + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue UnassignCardDeck deckId' cardId' -> do - liftIO $ do - runRIO (st ^. babel) $ runDB $ unassignCardDeck deckId' cardId' - -- writeBChan (st ^. chan) $ LoadCard cardId' - -- continue st - st1 <- reloadCards st >>= reloadTags - loadCurrCardMd st1 >>= continue - - AssignCardTag tagId cardId' -> error "assign card tag" - -- TODO: easy, adapt above - UnassignCardTag tagId cardId' -> error "unassign card tag" - -- TODO: easy, adapt above + runRIO (st ^. babel) $ runDB $ unassignCardDeck deckId' cardId' + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue + + AssignCardTag tagId' cardId' -> do + runRIO (st ^. babel) $ runDB $ assignCardTag tagId' cardId' + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue + + UnassignCardTag tagId' cardId' -> do + runRIO (st ^. babel) $ runDB $ unassignCardTag tagId' cardId' + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue CreateCard newCard -> do - cardId' <- liftIO $ runRIO (st ^. babel) $ runDB $ createCard newCard - -- writeBChan (st ^. chan) ReloadCards - -- writeBChan (st ^. chan) ReloadTags - -- continue st - st1 <- reloadCards st >>= reloadTags - loadCurrCardMd st1 >>= continue - -- FIXME? new card may not be selected card + _ <- runRIO (st ^. babel) $ runDB $ createCard newCard + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue DisableCard cardId' -> do - liftIO $ do - runRIO (st ^. babel) $ runDB - $ update cardId' [ CardEnabled =. False ] - -- writeBChan (st ^. chan) ReloadCards - -- writeBChan (st ^. chan) $ LoadCard cardId' - -- continue st - st1 <- reloadCards st >>= reloadTags - loadCurrCardMd st1 >>= continue + runRIO (st ^. babel) $ runDB $ update cardId' [ CardEnabled =. False ] + loadCards st >>= loadTags >>= loadCurrCardMd >>= continue EnableCard cardId' -> do - liftIO $ do - runRIO (st ^. babel) $ runDB - $ update cardId' [ CardEnabled =. True ] - -- writeBChan (st ^. chan) ReloadCards - -- writeBChan (st ^. chan) $ LoadCard cardId' - -- continue st - st1 <- reloadCards st >>= reloadTags - loadCurrCardMd st1 >>= continue + runRIO (st ^. babel) $ runDB $ update cardId' [ CardEnabled =. True ] + loadCards st >>= loadTags >>= continue -- LoadCard cardId' -> loadCardMd st cardId' >>= continue CreateDeck deck -> do - deckId' <- liftIO $ runRIO (st ^. babel) $ runDB $ insert deck + deckId' <- runRIO (st ^. babel) $ runDB $ insert deck continue $ st & deckMap %~ IntMap.insert (keyToInt deckId') (newDeckMetadata $ Entity deckId' deck) & availableDecks . listElementsL %~ (Seq.|> deckId') DeleteDeck deckId' -> do - liftIO $ runRIO (st ^. babel) $ runDB $ delete deckId' + runRIO (st ^. babel) $ runDB $ do + deleteWhere [ DeckMemberDeckId ==. deckId' ] + delete deckId' continue $ st & deckMap %~ IntMap.delete (keyToInt deckId') & availableDecks . listElementsL %~ Seq.filter (deckId' /=) - ReloadCards -> reloadCards st >>= continue - ReloadTags -> reloadTags st >>= continue + ReloadCards -> loadCards st >>= continue + ReloadTags -> loadTags st >>= continue -- ReloadEverything -> appStartEvent st >>= continue VtyEvent event -> case st ^. view of @@ -192,31 +146,25 @@ lifecycle = do updatedAvailTags <- runMaybeT $ do guard $ st1 ^. focusX == 1 lift $ handleListEvent event $ st1 ^. availableTags - updatedAvailCards <- runMaybeT $ do + updatedAvailCardsEnabled <- runMaybeT $ do guard $ st1 ^. focusX == 2 - lift $ handleListEvent event $ st1 ^. availableCards + lift $ handleListEvent event $ st1 ^. availableCardsEnabled let st2 = st1 - & availableCards .~ fromMaybe (st1 ^. availableCards) updatedAvailCards + & availableCardsEnabled .~ fromMaybe (st1 ^. availableCardsEnabled) updatedAvailCardsEnabled & availableDecks .~ fromMaybe (st1 ^. availableDecks) updatedAvailDecks & availableTags .~ fromMaybe (st1 ^. availableTags) updatedAvailTags let selectedCardId = fmap snd $ listSelectedElement - $ st2 ^. availableCards + $ st2 ^. availableCardsEnabled selectedDeckId = fmap snd $ listSelectedElement $ st2 ^. availableDecks selectedTagId = fmap snd $ listSelectedElement $ st2 ^. availableTags - -- activeCardHasChanged = st1 ^? activeCard . _Just . key - -- /= selectedCardId - - -- newState <- fmap (fromMaybe st1) <$> runMaybeT $ do - -- guard activeCardHasChanged - -- cardId' <- MaybeT $ return selectedCardId newState <- loadCurrCardMd st2 case event of @@ -225,11 +173,8 @@ lifecycle = do & focusX %~ max 0 . (\x -> x - 1) EvKey KRight [] -> continue $ newState & focusX %~ min 2 . (1+) - EvKey KIns [] -> do - _ <- liftIO $ runMaybeT $ do - scid <- MaybeT $ return selectedCardId - lift $ writeBChan (st2 ^. chan) $ EnableCard scid - continue newState + EvKey KIns [] -> + continue $ newState & view .~ CardsOverviewDisabled EvKey KDel [] -> do _ <- liftIO $ runMaybeT $ do scid <- MaybeT $ return selectedCardId @@ -264,6 +209,25 @@ lifecycle = do continue newState _ -> continue newState + CardsOverviewDisabled -> do + updatedAvailCardsDisabled <- handleListEvent event + $ st ^. availableCardsDisabled + + let newState = st + & availableCardsDisabled .~ updatedAvailCardsDisabled + selectedCardId = fmap snd + $ listSelectedElement + $ newState ^. availableCardsDisabled + + case event of + EvKey KEsc [] -> continue $ newState & view .~ CardsOverview + EvKey KEnter [] -> do + _ <- liftIO $ runMaybeT $ do + scid <- MaybeT $ return selectedCardId + lift $ writeBChan (newState ^. chan) $ EnableCard scid + continue newState + _ -> continue newState + AddNewDeck -> do updatedForm <- handleFormEvent evt $ st ^. deckForm let newState = st & deckForm .~ updatedForm @@ -380,9 +344,9 @@ lifecycle = do ] , borderWithLabel (str "Cards") $ renderList - (renderCardOption $ st ^. cardMap) + (renderCardOption $ st ^. cardMapEnabled) (st ^. focusX == 2) - $ st ^. availableCards + $ st ^. availableCardsEnabled ] , hCenter $ strWrap "Switch lists with left/right keys." , hCenter $ strWrap "Select list options with up/down keys." @@ -391,13 +355,24 @@ lifecycle = do , hCenter $ strWrap "Press D to assign the selected deck to a card." , hCenter $ strWrap "Press Ctrl+T to unassign the selected tag from a card." , hCenter $ strWrap "Press Ctrl+D to unassign the selected deck from a card." - , hCenter $ strWrap "Press INS to enable the selected card." + , hCenter $ strWrap "Press INS to manage disabled cards." , hCenter $ strWrap "Press DEL to disable the selected card." + , hCenter $ strWrap "Press ESC to return." ] - -- TODO: CardsOverviewDisabled - -- show all disabled cards and allow the user to enable them - -- that is all! + CardsOverviewDisabled -> applicationTitle + $ vBox + [ hBorderWithLabel (str "Disabled Cards") + , hCenter + $ vCenter + $ borderWithLabel (str "Cards") + $ renderList + (renderCardOption $ st ^. cardMapDisabled) + (st ^. focusX == 2) + $ st ^. availableCardsDisabled + , hCenter $ strWrap "Press ENTER to enable a card." + , hCenter $ strWrap "Press ESC to return." + ] CardManagement -> error "CardManagement" @@ -460,8 +435,7 @@ lifecycle = do let cardObverse = card ^. obverse cardReverse = card ^. reverse card = cmap ^?! at (keyToInt cardId') . _Just . val - cardStatus = if card ^. enabled then "[X]" else "[ ]" - cardLabel = ([i|#{cardStatus} #{cardObverse} / #{cardReverse}|]) + cardLabel = ([i|#{cardObverse} / #{cardReverse}|]) in padRight Max $ str cardLabel @@ -502,7 +476,8 @@ lifecycle = do , _activeCard = Nothing - , _cardMap = mempty + , _cardMapEnabled = mempty + , _cardMapDisabled = mempty , _deckMap = mempty , _tagMap = mempty @@ -513,7 +488,8 @@ lifecycle = do , _activeCardDecks = list "activeCardDecks" mempty 1 , _activeCardTags = list "activeCardTags" mempty 1 - , _availableCards = list "availableCards" 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 @@ -560,7 +536,7 @@ lifecycle = do loadCurrCardMd st = do let selectedCardId = fmap snd $ listSelectedElement - (st ^. availableCards) + (st ^. availableCardsEnabled) maybe (return st) (loadCardMd st) selectedCardId @@ -574,21 +550,51 @@ lifecycle = do & activeCardDecks .~ list "activeCardDecks" (Seq.fromList deckIds) 1 & activeCardTags .~ list "activeCardTags" (Seq.fromList tagIds) 1 - reloadCards st = do - availCards <- runRIO (st ^. babel) $ runDB retrieveCards + loadCards = loadCardsEnabled >=> loadCardsDisabled + loadCardsDisabled st = do + availCards <- runRIO (st ^. babel) $ runDB retrieveCardsDisabled let cmap = IntMap.fromList $ (\ce -> (keyToInt $ ce ^. key, ce)) <$> availCards cardIds = (^. key) <$> availCards - oldListSelected = st ^. availableCards . listSelectedL - newCardsList = list "availableCards" (Seq.fromList cardIds) 1 + oldListSelected = st ^. availableCardsDisabled . listSelectedL + newCardsList = list "availableCardsDisabled" (Seq.fromList cardIds) 1 & listSelectedL .~ oldListSelected return $ st - & cardMap .~ cmap - & availableCards .~ newCardsList + & cardMapDisabled .~ cmap + & availableCardsDisabled .~ newCardsList + + loadCardsEnabled st = do + availCards <- runRIO (st ^. babel) $ runDB retrieveCardsEnabled + let cmap = IntMap.fromList + $ (\ce -> (keyToInt $ ce ^. key, ce)) + <$> availCards + cardIds = (^. key) <$> availCards + oldListSelected = st ^. availableCardsEnabled . listSelectedL + newCardsList = list "availableCardsEnabled" (Seq.fromList cardIds) 1 + & listSelectedL .~ oldListSelected + + return $ st + & cardMapEnabled .~ cmap + & availableCardsEnabled .~ newCardsList + + loadDecks st = do + availDecks <- runRIO (st ^. babel) $ runDB $ retrieveDeckSummaries + let dmap = IntMap.fromList + $ (\dm -> (keyToInt $ dm ^. deckEntity . key, dm)) + <$> availDecks + deckIds = (^. deckEntity . key) <$> availDecks + + return + $ st + & deckMap .~ dmap + & availableDecks .~ list "availableDecks" (Seq.fromList deckIds) 1 + + loadModes = return + -- TODO: load modes, when lua scripting is implemented - reloadTags st = do + loadTags st = do availTags <- runRIO (st ^. babel) $ runDB retrieveTags let tmap = IntMap.fromList $ (\te -> (keyToInt $ te ^. key, te)) diff --git a/src/Types/TUI.hs b/src/Types/TUI.hs index a32faa6..213f720 100644 --- a/src/Types/TUI.hs +++ b/src/Types/TUI.hs @@ -17,41 +17,43 @@ import RIO hiding (view) import Types data BabelTUI = BabelTUI - { _babel :: !Babel - , _view :: !BabelView - , _chan :: !(BChan BabelEvent) + { _babel :: !Babel + , _view :: !BabelView + , _chan :: !(BChan BabelEvent) - , _focusX :: !Int + , _focusX :: !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 + , _focusY :: !Int -- ^ Top-to-bottom focus. -- Each view will set and interpret this as it will. -- Setting min/max bounds during view transitions is -- advised. - , _activeCard :: !(Maybe (Entity Card)) + , _activeCard :: !(Maybe (Entity Card)) - , _cardMap :: !(IntMap (Entity Card)) - , _deckMap :: !(IntMap DeckMetadata) - , _tagMap :: !(IntMap (Entity Tag)) + , _cardMapEnabled :: !(IntMap (Entity Card)) + , _cardMapDisabled :: !(IntMap (Entity Card)) + , _deckMap :: !(IntMap DeckMetadata) + , _tagMap :: !(IntMap (Entity Tag)) - , _answerForm :: !(Form Text BabelEvent String) - , _cardForm :: !(Form NewCard BabelEvent String) - , _deckForm :: !(Form Deck BabelEvent String) + , _answerForm :: !(Form Text BabelEvent String) + , _cardForm :: !(Form NewCard BabelEvent String) + , _deckForm :: !(Form Deck BabelEvent String) -- Display lists - , _activeCardDecks :: !(GenericList String Seq DeckId) - , _activeCardTags :: !(GenericList String Seq TagId) + , _activeCardDecks :: !(GenericList String Seq DeckId) + , _activeCardTags :: !(GenericList String Seq TagId) -- Interactive lists - , _availableCards :: !(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)) + , _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)) }