From 0282c8da11f71851855eaa433bfd1fe5fe52898e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 8 Sep 2020 16:58:29 +0200 Subject: Build a little include feature --- server/lib/Uplcg/Cards.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) (limited to 'server') diff --git a/server/lib/Uplcg/Cards.hs b/server/lib/Uplcg/Cards.hs index 27d5240..d7d7659 100644 --- a/server/lib/Uplcg/Cards.hs +++ b/server/lib/Uplcg/Cards.hs @@ -1,17 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} module Uplcg.Cards ( Deck , CardSets , loadCardSets ) where +import qualified Data.Aeson.TH as Aeson import qualified Data.HashMap.Strict as HMS +import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Vector as V import qualified Data.Yaml as Yaml +import Elm.Derive (defaultOptionsDropLower) import Uplcg.Messages type Deck = T.Text type CardSets = HMS.HashMap Deck Cards +data RawCardSet = RawCardSet + { rcsEnabled :: Maybe Bool + , rcsInclude :: Maybe (V.Vector T.Text) + , rcsBlack :: V.Vector T.Text + , rcsWhite :: V.Vector T.Text + } + +Aeson.deriveFromJSON (defaultOptionsDropLower 3) ''RawCardSet + +fromRawCardSets :: HMS.HashMap Deck RawCardSet -> CardSets +fromRawCardSets raws = + HMS.map (\rcs -> + let includes = V.mapMaybe (`HMS.lookup` raws) $ + fromMaybe V.empty $ rcsInclude rcs in + Cards + { cardsBlack = rcsBlack rcs <> V.concatMap rcsBlack includes + , cardsWhite = rcsWhite rcs <> V.concatMap rcsWhite includes + }) $ + HMS.filter (fromMaybe True . rcsEnabled) raws + loadCardSets :: FilePath -> IO CardSets -loadCardSets path = Yaml.decodeFileThrow path +loadCardSets path = fromRawCardSets <$> Yaml.decodeFileThrow path -- cgit v1.2.3