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)
|
