WIP. Assign tags, enable disable cards, refactor.

srhoulam · Jul 25, 2021 · 179fee6 · 179fee6
1 parent 20b708c
commit 179fee6
Show file tree

Hide file tree

Showing 3 changed files with 164 additions and 127 deletions.
diff --git 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