Fix bug in filterDesired function

.github/workflows/tests.yaml

@@ -27,7 +27,7 @@ jobs:
       - uses: actions/checkout@v3
 
       - name: Install Nix
-        uses: DeterminateSystems/nix-installer-action@v4
+        uses: cachix/install-nix-action@v31.7.0
 
       - name: Check Cachix token exists
         env:
@@ -39,7 +39,7 @@ jobs:
           fi
 
       - name: Setup cachix cache
-        uses: cachix/cachix-action@v12
+        uses: cachix/cachix-action@v16
         with:
           name: draftgen
           authToken: "${{ secrets.CACHIX_AUTH_TOKEN }}"
@@ -61,17 +61,20 @@ jobs:
           nix flake check
           nix run .#check-formatting
 
-      - name: Check Haskell formatting
-        uses: haskell-actions/run-fourmolu@v11
-        with:
-          version: "0.15.0.0"
-          pattern: |
-            src/**/*.hs
-            prelude/**/*.hs
-            test/**/*.hs
-
-          # Don't follow symbolic links to .hs files.
-          follow-symbolic-links: false
+      # Idk seems broken, and doesn't even print output from fourmolu
+      # if it the formatting check fails
+      #
+      # - name: Check Haskell formatting
+      #   uses: haskell-actions/run-fourmolu@v11
+      #   with:
+      #     version: "0.15.0.0"
+      #     pattern: |
+      #       src/**/*.hs
+      #       prelude/**/*.hs
+      #       test/**/*.hs
+
+      #     # Don't follow symbolic links to .hs files.
+      #     follow-symbolic-links: false
 
       - name: Update cabal packages
         run: nix develop -c cabal update

DraftGen.cabal

@@ -95,6 +95,7 @@ test-suite unit-tests
   build-depends:
     , aeson
     , base           ^>=4.19.2.0
+    , containers
     , dg-prelude
     , DraftGen
     , exceptions

flake.nix

@@ -52,15 +52,15 @@
           in "${script}/bin/${name}";
         };
         devShells.default = let
-          tools = with hpkgs;
-            [
+          tools =
+            (with hpkgs; [
               cabal-fmt
               cabal-install
               fourmolu
               ghc
               ghc-prof-flamegraph
               profiteur
-            ]
+            ])
             ++ (with pkgs; [
               ghciwatch
               haskell-language-server

src/DraftGen/File.hs

@@ -7,7 +7,7 @@
 
  Module for handling reading from and writing to files
 -}
-module File (execute, run) where
+module File (execute, getFromCache, run) where
 
 import CLI qualified
 import Control.Concurrent.Async qualified as Async
@@ -102,7 +102,7 @@ fetchSet set = do
   setInfoRes <- liftIO $ getScryfall manager ("https://api.scryfall.com/sets" </> set) []
   setInfo <- ExceptT . pure $ Json.eitherDecode @SetInfo setInfoRes.responseBody
   let pages :: [Int] =
-        enumFromTo 1 $ ceiling $ fromIntegral @_ @Double setInfo.cardCount / 175
+        enumFromTo 1 . succ $ setInfo.cardCount `div` 175
       getSetData page =
         getScryfall
           manager

src/DraftGen/Generate.hs

@@ -11,6 +11,7 @@ module Generate
   ( encodeFile
   , filterBySet
   , genLands
+  , genPack
   , genPacks
   , genTokens
   , readCards
@@ -73,7 +74,6 @@ filterDesired = S.filter $ \card ->
     [ \card -> card.layout `notElem` unwantedLayout
     , \card -> null $ card.frameEffects `intersect` unwantedFrameEffects
     , \card -> not card.variation
-    , \card -> not card.reprint
     , \card -> not card.fullArt
     , \card -> not card.promo
     , \card -> card.borderColor /= ColorBorderless
@@ -165,13 +165,13 @@ genTokens config = pure . filterBySet ('t' : config.set)
 
 -- | Generate a random pack based on the pack configuration
 genPack :: PackConfig -> HashSet CardObj -> IO (Seq CardObj)
-genPack config cards =
+genPack config setCards =
   if config.set == "stx"
-    then genStrixhavenPack config cards
+    then genStrixhavenPack config setCards
     else do
-      let setCards = english . filterBySet config.set . filterDesired $ cards
-          base = filterBasicLands Out setCards
-          english = S.filter (\c -> c.lang == "en")
+      let english = S.filter (\c -> c.lang == "en")
+          desiredCards = english . filterDesired $ setCards
+          base = filterBasicLands Out desiredCards
           fbr r = filterByRarity r base
           foils = S.filter (.foil) base
       commonWithMaybeFoilCards <-
@@ -187,10 +187,10 @@ fromSets = foldr ((Sq.><) . Sq.fromList . S.toList) Sq.empty
 -- | Generate a strixhaven pack (has special rules)
 genStrixhavenPack :: PackConfig -> HashSet CardObj -> IO (Seq CardObj)
 genStrixhavenPack config cards = do
-  let stxCards = english . filterBySet config.set . filterDesired $ cards
+  let stxCards = english . filterDesired $ cards
       baseNoLesson = filterLesson Out . filterBasicLands Out $ stxCards
       lessons = filterLesson In stxCards
-      staCards = english . filterBySet "sta" $ cards
+      staCards = english cards
       english = S.filter (\card -> card.lang == "en")
       fbr r = filterByRarity r baseNoLesson
       foils = S.filter (.foil) baseNoLesson

test/src/Main.hs

@@ -12,12 +12,15 @@ module Main where
 import CLI
 import Control.Monad.Catch
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Except (runExceptT)
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Aeson qualified as Json
 import Data.HashSet (HashSet)
 import Data.HashSet qualified as HS
-import File (run)
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+import File qualified
 import Generate (filterDesired, readCards)
+import Generate qualified
 import System.FilePath
 import Test.Sandwich
 import Types
@@ -66,8 +69,10 @@ testFrameEffectInverse = encodeDecodeIsInverse CompassLandDfc
 testBorderColorInverse :: (MonadIO m, MonadThrow m) => m ()
 testBorderColorInverse = encodeDecodeIsInverse ColorBlack
 
-genPacks :: (MonadIO m, MonadThrow m) => m ()
-genPacks = runExceptT (run config) *> shouldBe True True
+-- | Simulate running DraftGen from the command line
+-- This function generates packs, encodes and writes them to the file system.
+simulateMain :: (MonadIO m, MonadThrow m) => m ()
+simulateMain = runExceptT (File.run config) *> shouldBe True True
  where
   config =
     PackConfig
@@ -80,13 +85,37 @@ genPacks = runExceptT (run config) *> shouldBe True True
       , foilChance = Ratio 1 45
       }
 
+generatePack :: MonadIO m => PackConfig -> ExceptT String m (Seq CardObj)
+generatePack config = do
+  cards <- File.getFromCache config.set
+  liftIO $ Generate.genPack config cards
+
+generatesValidPack :: (MonadIO m, MonadThrow m) => m ()
+generatesValidPack = do
+  packRes <- runExceptT $ generatePack config
+  case packRes of
+    Left err -> expectationFailure err
+    Right pack -> Seq.length pack `shouldBe` (config.commons + config.uncommons + config.rareOrMythics)
+ where
+  config =
+    PackConfig
+      { amount = 6
+      , set = "om1"
+      , commons = 10
+      , uncommons = 3
+      , rareOrMythics = 1
+      , mythicChance = Ratio 1 8
+      , foilChance = Ratio 1 45
+      }
+
 basic :: TopSpec
 basic = describe "Unit tests" $ do
   it "filterDesired filters out undesired card types" testFilterDesired
   it "cardFace encode/decode are inverses" testCardFaceInverse
   it "frameEffect encode/decode are inverses" testFrameEffectInverse
   it "borderColor encode/decode are inverses" testBorderColorInverse
-  it "generates packs without throwing exceptions" genPacks
+  it "generates a valid pack with the expected contents" generatesValidPack
+  it "generates packs without throwing exceptions" simulateMain
 
 main :: IO ()
 main = runSandwichWithCommandLineArgs defaultOptions basic