summaryrefslogtreecommitdiff
path: root/cwality-maps/Config.hs
blob: 1317f72d2e53f2d57b98db6cb85258cc9709235d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE KindSignatures    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}

module Config ( loadConfig
              , Config, port, verbose, template
              ) where

import           Universum

import           Data.List           (isSuffixOf)
import qualified Data.Map.Strict     as M
import           Data.Tiled          (LoadResult (Loaded), Tiledmap,
                                      loadTiledmap)
import           Lens.Micro.Platform (makeLenses, traverseOf)
import           System.Directory    (listDirectory)
import           System.FilePath     ((</>))
import           Toml                (TomlCodec, (.=))
import qualified Toml                as T

type family ConfigRes (b :: Bool) a where
  ConfigRes True a = a
  ConfigRes False a = FilePath

-- | the server's configuration
data Config (loaded :: Bool) = Config
  { _port     :: Int
  , _verbose  :: Bool
  , _template :: ConfigRes loaded (FilePath, Map Text Tiledmap)
  } deriving Generic

makeLenses ''Config


configCodec :: TomlCodec (Config False)
configCodec = Config
    <$> T.int "port" .= _port
    <*> T.bool "verbose" .= _verbose
    <*> T.string "template" .= _template

loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
  T.decodeFileEither configCodec path >>= \case
    Right c  -> traverseOf template loadMaps c
    Left err -> error (show err)
    where loadMaps path = do
            maps <- listDirectory path
              <&> filter (".json" `isSuffixOf`)

            list <- forM maps $ \mapname ->
              loadTiledmap (path </> mapname) >>= \case
                Loaded tmap -> pure (toText mapname, tmap)
                err         -> error (show err)

            pure (path, M.fromList list)