From 05572a07c6952b494b629d05d620de188b09c128 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Mon, 29 Sep 2025 18:57:02 +0200 Subject: [PATCH 1/7] fix bug in `filterDesired` function allow reprints --- src/DraftGen/Generate.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/DraftGen/Generate.hs b/src/DraftGen/Generate.hs index bd2607e..3c0528b 100644 --- a/src/DraftGen/Generate.hs +++ b/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 From 36f17d550558cfc85eef60cba4ad642309290c72 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Mon, 29 Sep 2025 18:57:18 +0200 Subject: [PATCH 2/7] add test: catch empty pack generation bug --- test/src/Main.hs | 39 ++++++++++++++++++++++++++++++++++----- 1 file changed, 34 insertions(+), 5 deletions(-) diff --git a/test/src/Main.hs b/test/src/Main.hs index 417c314..1e85e4b 100644 --- a/test/src/Main.hs +++ b/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 From 3008014ba6afe5a1b663fc361af7d8d21779c784 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Mon, 29 Sep 2025 18:57:53 +0200 Subject: [PATCH 3/7] optimise fetchSet function --- src/DraftGen/File.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/DraftGen/File.hs b/src/DraftGen/File.hs index 40f95f4..9c08e46 100644 --- a/src/DraftGen/File.hs +++ b/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 From 1938d8efcb93f7e0f9c0758f4c3779933504300c Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Mon, 29 Sep 2025 18:58:10 +0200 Subject: [PATCH 4/7] dep stuff --- DraftGen.cabal | 1 + flake.nix | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/DraftGen.cabal b/DraftGen.cabal index a3b89ac..7b570a4 100644 --- a/DraftGen.cabal +++ b/DraftGen.cabal @@ -95,6 +95,7 @@ test-suite unit-tests build-depends: , aeson , base ^>=4.19.2.0 + , containers , dg-prelude , DraftGen , exceptions diff --git a/flake.nix b/flake.nix index 5d49eae..4eb1466 100644 --- a/flake.nix +++ b/flake.nix @@ -52,7 +52,7 @@ in "${script}/bin/${name}"; }; devShells.default = let - tools = with hpkgs; + tools = (with hpkgs; [ cabal-fmt cabal-install @@ -60,7 +60,7 @@ ghc ghc-prof-flamegraph profiteur - ] + ]) ++ (with pkgs; [ ghciwatch haskell-language-server @@ -74,7 +74,7 @@ hpkgs.shellFor { name = "draftgen-dev-shell"; - packages = p: [self'.packages.draftgen]; + packages = p: [ self'.packages.draftgen ]; withHoogle = true; buildInputs = tools ++ libraries; From 2f915ebeb1b94890bc529472e93c15a76ce357cb Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Sat, 11 Oct 2025 20:17:02 +0200 Subject: [PATCH 5/7] format flake.nix --- flake.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/flake.nix b/flake.nix index 4eb1466..b988822 100644 --- a/flake.nix +++ b/flake.nix @@ -52,8 +52,8 @@ in "${script}/bin/${name}"; }; devShells.default = let - tools = (with hpkgs; - [ + tools = + (with hpkgs; [ cabal-fmt cabal-install fourmolu @@ -74,7 +74,7 @@ hpkgs.shellFor { name = "draftgen-dev-shell"; - packages = p: [ self'.packages.draftgen ]; + packages = p: [self'.packages.draftgen]; withHoogle = true; buildInputs = tools ++ libraries; From 37f97f0d737875c0d6f9649333dc967282047ac6 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Sat, 11 Oct 2025 20:18:36 +0200 Subject: [PATCH 6/7] replace detsys nix install action since they'll remove support for installing cppnix in favour of only providing access to their own proprietary nix fork. --- .github/workflows/tests.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 4eb071d..7db0559 100644 --- a/.github/workflows/tests.yaml +++ b/.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 }}" From 3e701ac47c7e6e546f84a692b739eb8a0b380615 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Sat, 11 Oct 2025 20:39:56 +0200 Subject: [PATCH 7/7] remove fourmolu step --- .github/workflows/tests.yaml | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 7db0559..db764dd 100644 --- a/.github/workflows/tests.yaml +++ b/.github/workflows/tests.yaml @@ -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