{-# LANGUAGE OverloadedStrings #-}
module Swarm.Game.ResourceLoading where
import Control.Algebra (Has)
import Control.Effect.Lift (Lift, sendIO)
import Control.Effect.Throw (Throw, liftEither, throwError)
import Control.Exception (catch)
import Control.Exception.Base (IOException)
import Control.Monad (forM, when, (<=<))
import Data.Array (Array, listArray)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Paths_swarm (getDataDir)
import Swarm.Game.Failure
import Swarm.Util
import System.Directory (
XdgDirectory (XdgData),
createDirectoryIfMissing,
doesDirectoryExist,
doesFileExist,
getXdgDirectory,
listDirectory,
)
import System.FilePath
import Witch
data NameGenerator = NameGenerator
{ NameGenerator -> Array Int Text
adjList :: Array Int Text
, NameGenerator -> Array Int Text
nameList :: Array Int Text
}
getDataDirSafe ::
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData ->
FilePath ->
m FilePath
getDataDirSafe :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataDirSafe AssetData
asset FilePath
p = do
FilePath
d <- (FilePath -> FilePath -> FilePath
`appDir` FilePath
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO IO FilePath
getDataDir
Bool
de <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
d
if Bool
de
then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
d
else do
FilePath
xd <- (FilePath -> FilePath -> FilePath
`appDir` FilePath
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir Bool
False FilePath
"data")
Bool
xde <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
xd
if Bool
xde then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
xd else forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
asset) FilePath
xd forall a b. (a -> b) -> a -> b
$ Entry -> LoadingFailure
DoesNotExist Entry
Directory
where
appDir :: FilePath -> FilePath -> FilePath
appDir FilePath
r = \case
FilePath
"" -> FilePath
r
FilePath
"." -> FilePath
r
FilePath
d -> FilePath
r FilePath -> FilePath -> FilePath
</> FilePath
d
getDataFileNameSafe ::
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData ->
FilePath ->
m FilePath
getDataFileNameSafe :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataFileNameSafe AssetData
asset FilePath
name = do
FilePath
d <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataDirSafe AssetData
asset FilePath
"."
let fp :: FilePath
fp = FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
name
Bool
fe <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fp
if Bool
fe
then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp
else forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
asset) FilePath
fp forall a b. (a -> b) -> a -> b
$ Entry -> LoadingFailure
DoesNotExist Entry
File
dataNotFound :: FilePath -> IO LoadingFailure
dataNotFound :: FilePath -> IO LoadingFailure
dataNotFound FilePath
f = do
FilePath
d <- Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir Bool
False FilePath
""
let squotes :: FilePath -> Text
squotes = Text -> Text
squote forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Text -> LoadingFailure
CustomMessage forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unlines
[ Text
"Could not find the data: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
squotes FilePath
f
, Text
"Try downloading the Swarm 'data' directory to: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
squotes (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
"data")
]
getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir Bool
createDirs FilePath
subDir = do
FilePath
swarmData <- (FilePath -> FilePath -> FilePath
</> FilePath
subDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData FilePath
"swarm"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createDirs (Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
swarmData)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
swarmData
getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataFile :: Bool -> FilePath -> IO FilePath
getSwarmXdgDataFile Bool
createDirs FilePath
filepath = do
let (FilePath
subDir, FilePath
file) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
filepath
FilePath
d <- Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir Bool
createDirs FilePath
subDir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
file
getSwarmSavePath :: Bool -> IO FilePath
getSwarmSavePath :: Bool -> IO FilePath
getSwarmSavePath Bool
createDirs = Bool -> FilePath -> IO FilePath
getSwarmXdgDataSubdir Bool
createDirs FilePath
"saves"
getSwarmHistoryPath :: Bool -> IO FilePath
getSwarmHistoryPath :: Bool -> IO FilePath
getSwarmHistoryPath Bool
createDirs = Bool -> FilePath -> IO FilePath
getSwarmXdgDataFile Bool
createDirs FilePath
"history"
readAppData ::
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m (Map Text Text)
readAppData :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m (Map Text Text)
readAppData = do
FilePath
d <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataDirSafe AssetData
AppAsset FilePath
"."
[FilePath]
dirMembers :: [FilePath] <-
(forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Either e a -> m a
liftEither forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO) forall a b. (a -> b) -> a -> b
$
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
d) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
AppAsset) FilePath
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LoadingFailure
CustomMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show IOException
e
let fs :: [FilePath]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== FilePath
".txt") forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) [FilePath]
dirMembers
[(Text, Maybe Text)]
filesList <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
fs (\FilePath
f -> (forall target source. From source target => source -> target
into @Text (FilePath -> FilePath
dropExtension FilePath
f),) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe Text)
readFileMayT (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
f))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$ [(Text, Maybe Text)]
filesList
initNameGenerator :: Has (Throw SystemFailure) sig m => Map Text Text -> m NameGenerator
initNameGenerator :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
Map Text Text -> m NameGenerator
initNameGenerator Map Text Text
appDataMap = do
[Text]
adjs <- forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Member (Throw SystemFailure) sig, Algebra sig m) =>
Text -> m [Text]
getDataLines Text
"adjectives"
[Text]
names <- forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Member (Throw SystemFailure) sig, Algebra sig m) =>
Text -> m [Text]
getDataLines Text
"names"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
NameGenerator
{ adjList :: Array Int Text
adjList = forall {e}. [e] -> Array Int e
makeArr [Text]
adjs
, nameList :: Array Int Text
nameList = forall {e}. [e] -> Array Int e
makeArr [Text]
names
}
where
makeArr :: [e] -> Array Int e
makeArr [e]
xs = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [e]
xs forall a. Num a => a -> a -> a
- Int
1) [e]
xs
getDataLines :: Text -> m [Text]
getDataLines Text
f = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
f Map Text Text
appDataMap of
Maybe Text
Nothing ->
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
NameGeneration) (forall target source. From source target => source -> target
into @FilePath Text
f FilePath -> FilePath -> FilePath
<.> FilePath
"txt") (Entry -> LoadingFailure
DoesNotExist Entry
File)
Just Text
content -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ Text
content