From 71118f69dd12486fdece8df0a9edb75996ba9ab1 Mon Sep 17 00:00:00 2001 From: skykanin <3789764+skykanin@users.noreply.github.com> Date: Thu, 21 Aug 2025 19:01:11 +0200 Subject: [PATCH] derive encode/decode to json instances --- DraftGen.cabal | 1 + flake.nix | 2 +- src/DraftGen/Types.hs | 189 +++++++++++++++++------------------------- src/DraftGen/Util.hs | 29 +++---- test/src/Main.hs | 16 ++++ 5 files changed, 103 insertions(+), 134 deletions(-) diff --git a/DraftGen.cabal b/DraftGen.cabal index 0f643b6..c8ddf61 100644 --- a/DraftGen.cabal +++ b/DraftGen.cabal @@ -93,6 +93,7 @@ test-suite unit-tests main-is: Main.hs other-modules: build-depends: + , aeson , base ^>=4.19.2.0 , dg-prelude , DraftGen diff --git a/flake.nix b/flake.nix index 8bc48d2..41d04b9 100644 --- a/flake.nix +++ b/flake.nix @@ -53,10 +53,10 @@ fourmolu ghc ghc-prof-flamegraph - ghcid profiteur ] ++ (with pkgs; [ + ghciwatch haskell-language-server nixd ]); diff --git a/src/DraftGen/Types.hs b/src/DraftGen/Types.hs index db4282b..048c7e9 100644 --- a/src/DraftGen/Types.hs +++ b/src/DraftGen/Types.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE UndecidableInstances #-} + {- | - Module : Types - License : GNU GPL, version 3 or above - Maintainer : skykanin <3789764+skykanin@users.noreply.github.com> - Stability : alpha - Portability : portable +Module : Types +License : GNU GPL, version 3 or above +Maintainer : skykanin <3789764+skykanin@users.noreply.github.com> +Stability : alpha +Portability : portable - Module defining the data types representing cards +Module defining the data types representing cards -} module Types ( PackConfig (..) @@ -14,7 +19,6 @@ module Types , FrameEffect (..) , CardFace (..) , CardObj (..) - , BulkDataObj (..) , SetInfo (..) , SetDataObj (..) , CardImgObj (..) @@ -32,11 +36,13 @@ where import CLI (Args (..), Ratio, Unwrapped) import Data.Aeson ( FromJSON (parseJSON) + , GToJSON , KeyValue ((.=)) , Object , Options (constructorTagModifier, fieldLabelModifier) , ToJSON (toJSON) - , Value (Object, String) + , Value (Object) + , camelTo2 , defaultOptions , genericParseJSON , genericToJSON @@ -48,13 +54,58 @@ import Data.Aeson ) import Data.Aeson.Key (fromString) import Data.Aeson.KeyMap qualified as M +import Data.Aeson.Types (GFromJSON, Zero) import Data.Char (toLower) import Data.Hashable (Hashable) import Data.Sequence (Seq) import Data.Sequence qualified as Seq -import GHC.Generics (Generic) +import GHC.Generics (Generic (..)) import Text.Printf (printf) -import Util (packName, snakeCase) +import Util (packName, splitOn) + +newtype ConfigJSON (opts :: JsonOption) a = ConfigJSON a + +type data JsonOption = SnakeCase | LowerCase | StripPrefix + +class HasJsonOptions tag where + jsonOptions :: Options + +instance HasJsonOptions SnakeCase where + jsonOptions = + defaultOptions + { fieldLabelModifier = camelTo2 '_' + , constructorTagModifier = toLowerCase + } + +instance HasJsonOptions LowerCase where + jsonOptions = + defaultOptions + { constructorTagModifier = toLowerCase + , fieldLabelModifier = toLowerCase + } + +-- | Strips a camelcased prefix of constructor tag and lowercases it +-- +-- >>> constructorTagModifier "ColorRed" +-- "red" +instance HasJsonOptions StripPrefix where + jsonOptions = + defaultOptions + { constructorTagModifier = + toLowerCase . (!! 1) . splitOn '_' . camelTo2 '_' + } + +instance + (Generic a, GToJSON Zero (Rep a), HasJsonOptions tag) + => ToJSON (ConfigJSON tag a) + where + toJSON = genericToJSON (jsonOptions @tag) . (\(ConfigJSON x) -> x) + +instance + (Generic a, GFromJSON Zero (Rep a), HasJsonOptions tag) + => FromJSON (ConfigJSON tag a) + where + parseJSON = fmap ConfigJSON . genericParseJSON (jsonOptions @tag) data PackConfig = PackConfig { amount :: Int @@ -82,18 +133,8 @@ toLowerCase = map toLower data Rarity = Common | Uncommon | Rare | Mythic | Special | Bonus deriving stock (Enum, Eq, Generic, Show) - -instance Hashable Rarity - -instance ToJSON Rarity where - toJSON = genericToJSON defaultOptions {constructorTagModifier = toLowerCase} - -instance FromJSON Rarity where - parseJSON = - genericParseJSON - defaultOptions - { constructorTagModifier = toLowerCase - } + deriving anyclass (Hashable) + deriving (FromJSON, ToJSON) via (ConfigJSON LowerCase Rarity) data UriObj = UriObj { small :: String @@ -102,10 +143,9 @@ data UriObj = UriObj , png :: String } deriving stock (Eq, Generic, Show) + deriving anyclass (Hashable) deriving anyclass (FromJSON, ToJSON) -instance Hashable UriObj - data FrameEffect = Legendary | Miracle @@ -137,22 +177,8 @@ data FrameEffect | Fullart | Vehicle deriving stock (Eq, Generic, Show) - -instance Hashable FrameEffect - -instance ToJSON FrameEffect where - toJSON = - genericToJSON - defaultOptions - { constructorTagModifier = toLowerCase - } - -instance FromJSON FrameEffect where - parseJSON = - genericParseJSON - defaultOptions - { constructorTagModifier = toLowerCase - } + deriving anyclass (Hashable) + deriving (FromJSON, ToJSON) via (ConfigJSON LowerCase FrameEffect) data CardFace = CardFace { name :: String @@ -160,13 +186,7 @@ data CardFace = CardFace } deriving stock (Eq, Generic, Show) deriving anyclass (Hashable) - -instance ToJSON CardFace where - toJSON = genericToJSON defaultOptions {fieldLabelModifier = snakeCase} - -instance FromJSON CardFace where - parseJSON = withObject "CardFace" $ \v -> - CardFace <$> v .: "name" <*> v .:? "image_uris" + deriving (FromJSON, ToJSON) via (ConfigJSON SnakeCase CardFace) data CardObj = CardObj { id :: String @@ -190,19 +210,13 @@ data CardObj = CardObj } deriving stock (Generic, Show) deriving anyclass (Hashable) + deriving (ToJSON) via (ConfigJSON SnakeCase CardObj) -- | Check card equality only by name instance Eq CardObj where cardObjA == cardObjB = cardObjA.name == cardObjB.name -instance ToJSON CardObj where - toJSON = - genericToJSON - defaultOptions - { fieldLabelModifier = snakeCase - } - instance FromJSON CardObj where parseJSON = withObject "CardObj" $ \v -> CardObj @@ -234,36 +248,7 @@ data BorderColor | ColorYellow deriving stock (Eq, Generic, Show) deriving anyclass (Hashable) - -instance ToJSON BorderColor where - toJSON = - genericToJSON - defaultOptions - { constructorTagModifier = toLowerCase . drop 5 - } - -instance FromJSON BorderColor where - parseJSON = - genericParseJSON - defaultOptions - { constructorTagModifier = toLowerCase . drop 5 - } - -data BulkDataObj = BulkDataObj - { id :: String - , bulkType :: String - , name :: String - , downloadUri :: String - } - deriving stock (Generic, Show) - -instance FromJSON BulkDataObj where - parseJSON = withObject "BulkDataObj" $ \v -> - BulkDataObj - <$> v .: "id" - <*> v .: "type" - <*> v .: "name" - <*> v .: "download_uri" + deriving (FromJSON, ToJSON) via (ConfigJSON StripPrefix BorderColor) data SetInfo = SetInfo { id :: String @@ -274,16 +259,7 @@ data SetInfo = SetInfo , cardCount :: Int } deriving stock (Generic, Show) - -instance FromJSON SetInfo where - parseJSON = withObject "SetInfo" $ \v -> - SetInfo - <$> v .: "id" - <*> v .: "code" - <*> v .: "search_uri" - <*> v .: "released_at" - <*> v .: "set_type" - <*> v .: "card_count" + deriving (FromJSON) via (ConfigJSON SnakeCase SetInfo) data SetDataObj = SetDataObj { object :: String @@ -292,14 +268,7 @@ data SetDataObj = SetDataObj , cardData :: [CardObj] } deriving stock (Generic, Show) - -instance FromJSON SetDataObj where - parseJSON = withObject "SetDataObj" $ \v -> - SetDataObj - <$> v .: "object" - <*> v .: "total_cards" - <*> v .: "has_more" - <*> v .: "data" + deriving (FromJSON) via (ConfigJSON SnakeCase SetDataObj) toObject :: Seq CardImgObj -> Value toObject = Object . go 1 M.empty @@ -317,14 +286,11 @@ data CardImgObj = CardImgObj , faceURL :: String } deriving stock (Generic, Show) - -instance ToJSON CardImgObj + deriving anyclass (ToJSON) data ObjType = Card deriving stock (Generic, Show) - -instance ToJSON ObjType where - toJSON Card = String "Card" + deriving anyclass (ToJSON) data TransformObj = TransformObj { scaleZ :: Int @@ -347,14 +313,7 @@ data TTSCardObj = TTSCardObj , cardID :: Int } deriving stock (Generic, Show) - -instance ToJSON TTSCardObj where - toJSON = - genericToJSON $ - defaultOptions {fieldLabelModifier = lower} - where - lower [] = [] - lower (x : xs) = toLower x : xs + deriving (ToJSON) via (ConfigJSON LowerCase TTSCardObj) data GameObj = GameObj { transform :: TransformObj diff --git a/src/DraftGen/Util.hs b/src/DraftGen/Util.hs index 26a2ae5..29f5831 100644 --- a/src/DraftGen/Util.hs +++ b/src/DraftGen/Util.hs @@ -12,29 +12,22 @@ module Util , cardCacheName , landName , packName - , snakeCase , tokenName + , splitOn ) where -import Data.Char - -snakeCase :: String -> String -snakeCase = symbCase '_' - --- | Generic casing for symbol separated names -symbCase :: Char -> (String -> String) -symbCase sym = u . applyFirst toLower +-- | Split a list on a delimiter element. The delimiter is removed. +-- Example: splitOn ',' "a,b,,c" == ["a","b","","c"] +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn delim = go where - u [] = [] - u (x : xs) - | isUpper x = sym : toLower x : u xs - | otherwise = x : u xs - -applyFirst :: (Char -> Char) -> String -> String -applyFirst _ [] = [] -applyFirst f [x] = [f x] -applyFirst f (x : xs) = f x : xs + go [] = [[]] + go (x : xs) + | x == delim = [] : go xs + | otherwise = case go xs of + [] -> [[x]] + (y : ys) -> (x : y) : ys appName :: FilePath appName = "DraftGen" diff --git a/test/src/Main.hs b/test/src/Main.hs index c9008a5..0f9c27a 100644 --- a/test/src/Main.hs +++ b/test/src/Main.hs @@ -11,6 +11,7 @@ module Main where import Control.Monad.Catch import Control.Monad.IO.Class +import Data.Aeson qualified as Json import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Generate (filterDesired, readCards) @@ -50,9 +51,24 @@ testFilters expectedLength eitherCards = cardObj.variation `shouldBe` False cardObj.borderColor `shouldNotBe` ColorBorderless +encodeDecodeIsInverse :: (MonadIO m, MonadThrow m, Json.FromJSON a, Json.ToJSON a, Eq a, Show a) => a -> m () +encodeDecodeIsInverse v = Json.decode (Json.encode v) `shouldBe` Just v + +testCardFaceInverse :: (MonadIO m, MonadThrow m) => m () +testCardFaceInverse = encodeDecodeIsInverse CardFace {name = "Back", imageUris = Nothing} + +testFrameEffectInverse :: (MonadIO m, MonadThrow m) => m () +testFrameEffectInverse = encodeDecodeIsInverse CompassLandDfc + +testBorderColorInverse :: (MonadIO m, MonadThrow m) => m () +testBorderColorInverse = encodeDecodeIsInverse ColorBlack + 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 main :: IO () main = runSandwichWithCommandLineArgs defaultOptions basic