module Mischief.Assets.Internal.Path where

import Control.Monad.IO.Class
import Data.List (unsnoc)
import Data.Text (Text)
import Data.Text qualified as T
import Mischief.ECS (Component, MonadSystem, insertRes, res)
import Mischief.ECS.App (App (..))
import Mischief.ECS.Utils (fromMaybeM)
import Mischief.ECS.World (runSystem)
import Path (Path, (</>))
import Path qualified
import System.Directory

setAssetSource :: Text -> App -> IO ()
setAssetSource :: Text -> App -> IO ()
setAssetSource Text
t App
app =
  System () -> World -> IO ()
forall a. System a -> World -> IO a
runSystem
    ( do
        path <- Text -> System (Path Abs Dir)
forall w (m :: * -> *). MonadSystem w m => Text -> m (Path Abs Dir)
relPathToAbsDir Text
t
        insertRes $ AssetSource path
    )
    App
app.world

newtype AssetSource = AssetSource (Path Path.Abs Path.Dir) deriving anyclass (Typeable AssetSource
[HookRel AssetSource]
[Hook AssetSource]
Set DefaultComponentType
IsExclusive (IsExclusiveRel AssetSource)
(Typeable AssetSource, IsExclusive (IsExclusiveRel AssetSource)) =>
Set DefaultComponentType
-> [Hook AssetSource]
-> [Hook AssetSource]
-> [Hook AssetSource]
-> [HookRel AssetSource]
-> [HookRel AssetSource]
-> [HookRel AssetSource]
-> Component AssetSource
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook AssetSource]
onAdd :: [Hook AssetSource]
$conSet :: [Hook AssetSource]
onSet :: [Hook AssetSource]
$conRemove :: [Hook AssetSource]
onRemove :: [Hook AssetSource]
$conAddRel :: [HookRel AssetSource]
onAddRel :: [HookRel AssetSource]
$conSetRel :: [HookRel AssetSource]
onSetRel :: [HookRel AssetSource]
$conRemoveRel :: [HookRel AssetSource]
onRemoveRel :: [HookRel AssetSource]
Component)

defAbsAssetSource :: (MonadSystem w m) => m AssetSource
defAbsAssetSource :: forall w (m :: * -> *). MonadSystem w m => m AssetSource
defAbsAssetSource = do
  path <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeAbsolute FilePath
"./"
  AssetSource <$> Path.parseAbsDir path

relAssetToAbsFile :: (MonadSystem w m) => Text -> m (Path Path.Abs Path.File)
relAssetToAbsFile :: forall w (m :: * -> *).
MonadSystem w m =>
Text -> m (Path Abs File)
relAssetToAbsFile Text
path = do
  (AssetSource s) <- m AssetSource -> Maybe AssetSource -> m AssetSource
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
fromMaybeM m AssetSource
forall w (m :: * -> *). MonadSystem w m => m AssetSource
defAbsAssetSource (Maybe AssetSource -> m AssetSource)
-> m (Maybe AssetSource) -> m AssetSource
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @AssetSource
  let chunks = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\\") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
path
  case unsnoc chunks of
    Maybe ([Text], Text)
Nothing -> m (Path Abs File)
forall a. HasCallStack => a
undefined
    Just ([Text]
xs, Text
last) -> do
      x :: Path Path.Abs Path.Dir <- Path Abs Dir -> [FilePath] -> m (Path Abs Dir)
forall {m :: * -> *} {b}.
MonadThrow m =>
Path b Dir -> [FilePath] -> m (Path b Dir)
f Path Abs Dir
s ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
xs)
      last <- Path.parseRelFile $ T.unpack last
      pure $ x </> last
  where
    f :: Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr (FilePath
".." : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f (Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
Path.parent Path b Dir
curr) [FilePath]
xs
    f Path b Dir
curr (FilePath
"" : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr [FilePath]
xs
    f Path b Dir
curr (FilePath
x : [FilePath]
xs) = do
      d <- FilePath -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
Path.parseRelDir FilePath
x
      f (curr </> d) xs
    f Path b Dir
curr [] = Path b Dir -> m (Path b Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path b Dir
curr

relPathToAbsFile :: (MonadSystem w m) => Text -> m (Path Path.Abs Path.File)
relPathToAbsFile :: forall w (m :: * -> *).
MonadSystem w m =>
Text -> m (Path Abs File)
relPathToAbsFile Text
path = do
  x <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeAbsolute FilePath
"."
  s <- Path.parseAbsDir x
  let chunks = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\\") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
path
  case unsnoc chunks of
    Maybe ([Text], Text)
Nothing -> m (Path Abs File)
forall a. HasCallStack => a
undefined
    Just ([Text]
xs, Text
last) -> do
      x :: Path Path.Abs Path.Dir <- Path Abs Dir -> [FilePath] -> m (Path Abs Dir)
forall {m :: * -> *} {b}.
MonadThrow m =>
Path b Dir -> [FilePath] -> m (Path b Dir)
f Path Abs Dir
s ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
xs)
      last <- Path.parseRelFile $ T.unpack last
      pure $ x </> last
  where
    f :: Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr (FilePath
".." : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f (Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
Path.parent Path b Dir
curr) [FilePath]
xs
    f Path b Dir
curr (FilePath
"" : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr [FilePath]
xs
    f Path b Dir
curr (FilePath
x : [FilePath]
xs) = do
      d <- FilePath -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
Path.parseRelDir FilePath
x
      f (curr </> d) xs
    f Path b Dir
curr [] = Path b Dir -> m (Path b Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path b Dir
curr

relPathToAbsDir :: (MonadSystem w m) => Text -> m (Path Path.Abs Path.Dir)
relPathToAbsDir :: forall w (m :: * -> *). MonadSystem w m => Text -> m (Path Abs Dir)
relPathToAbsDir Text
path = do
  x <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeAbsolute FilePath
"."
  s <- Path.parseAbsDir x
  let chunks = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\\") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
path
  f s (map T.unpack chunks)
  where
    f :: Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr (FilePath
".." : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f (Path b Dir -> Path b Dir
forall b t. Path b t -> Path b Dir
Path.parent Path b Dir
curr) [FilePath]
xs
    f Path b Dir
curr (FilePath
"" : [FilePath]
xs) = Path b Dir -> [FilePath] -> m (Path b Dir)
f Path b Dir
curr [FilePath]
xs
    f Path b Dir
curr (FilePath
x : [FilePath]
xs) = do
      d <- FilePath -> m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
Path.parseRelDir FilePath
x
      f (curr </> d) xs
    f Path b Dir
curr [] = Path b Dir -> m (Path b Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path b Dir
curr