Skip to content
Snippets Groups Projects
Select Git revision
8 results Searching

WriteRepo.hs

  • Config.hs 1.89 KiB
    {-# 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          (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
                    Right tmap -> pure (toText mapname, tmap)
                    err         -> error (show err)
    
                pure (path, M.fromList list)