From ffedfd5274a3545f2bc53bba7aa7ec3b4388edf1 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Fri, 11 Sep 2020 13:14:19 +0200
Subject: Add default card set

---
 server/lib/Uplcg/Cards.hs | 39 ++++++++++++++++++++++++++-------------
 1 file changed, 26 insertions(+), 13 deletions(-)

(limited to 'server/lib/Uplcg/Cards.hs')

diff --git a/server/lib/Uplcg/Cards.hs b/server/lib/Uplcg/Cards.hs
index d7d7659..b089574 100644
--- a/server/lib/Uplcg/Cards.hs
+++ b/server/lib/Uplcg/Cards.hs
@@ -1,13 +1,14 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Uplcg.Cards
     ( Deck
-    , CardSets
+    , CardSets (..)
     , loadCardSets
     ) where
 
 import qualified Data.Aeson.TH       as Aeson
 import qualified Data.HashMap.Strict as HMS
-import           Data.Maybe          (fromMaybe)
+import           Data.Maybe          (fromMaybe, listToMaybe)
 import qualified Data.Text           as T
 import qualified Data.Vector         as V
 import qualified Data.Yaml           as Yaml
@@ -16,27 +17,39 @@ import           Uplcg.Messages
 
 type Deck = T.Text
 
-type CardSets = HMS.HashMap Deck Cards
+data CardSets = CardSets
+    { csDefault :: Maybe Deck
+    , csCards   :: HMS.HashMap Deck Cards
+    } deriving (Show)
 
 data RawCardSet = RawCardSet
-    { rcsEnabled :: Maybe Bool
+    { rcsDefault :: Maybe Bool
+    , rcsEnabled :: Maybe Bool
     , rcsInclude :: Maybe (V.Vector T.Text)
     , rcsBlack   :: V.Vector T.Text
     , rcsWhite   :: V.Vector T.Text
-    }
+    } deriving (Show)
 
 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
+    CardSets {..}
+  where
+    csDefault = listToMaybe
+        [ deck
+        | (deck, RawCardSet {..}) <- HMS.toList raws
+        , fromMaybe False rcsDefault
+        ]
+    csCards =
+        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 = fromRawCardSets <$> Yaml.decodeFileThrow path
-- 
cgit v1.2.3