{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.Assets.Internal.Kdl where

import Data.Data
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Base
import GHC.Generics
import GHC.TypeLits
import KDL qualified
import Linear (V2)
import Mischief.Assets.Internal.Asset
import Mischief.Assets.Internal.Kdl.Collection
import Mischief.Assets.Orphans
import Mischief.ECS.Components.Bundle (Bundle)
import Mischief.ECS.Utils (mapLeft)

class (Typeable a) => KdlAsset a where
  decodeKdl :: RelativePath -> KDL.NodeDecoder a
  default decodeKdl :: (Generic a, GKdlAsset (Rep a)) => RelativePath -> KDL.NodeDecoder a
  decodeKdl RelativePath
x = NodeListDecodeArrow () a -> NodeDecoder a
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
KDL.children (Rep a (ZonkAny 0) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 0) -> a)
-> DecodeArrow NodeList () (Rep a (ZonkAny 0))
-> NodeListDecodeArrow () a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (p :: k).
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
forall (f :: * -> *) p.
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
decodeKdl' @(Rep a) RelativePath
x)

class GKdlAsset f where
  decodeKdl' :: RelativePath -> KDL.NodeListDecoder (f p)

data KdlRef a = KdlRef Text | KdlValue a deriving (Int -> KdlRef a -> ShowS
[KdlRef a] -> ShowS
KdlRef a -> String
(Int -> KdlRef a -> ShowS)
-> (KdlRef a -> String) -> ([KdlRef a] -> ShowS) -> Show (KdlRef a)
forall a. Show a => Int -> KdlRef a -> ShowS
forall a. Show a => [KdlRef a] -> ShowS
forall a. Show a => KdlRef a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> KdlRef a -> ShowS
showsPrec :: Int -> KdlRef a -> ShowS
$cshow :: forall a. Show a => KdlRef a -> String
show :: KdlRef a -> String
$cshowList :: forall a. Show a => [KdlRef a] -> ShowS
showList :: [KdlRef a] -> ShowS
Show)

instance GKdlAsset V1 where
  decodeKdl' :: forall (p :: k). RelativePath -> NodeListDecoder (V1 p)
decodeKdl' RelativePath
_ = NodeListDecoder (V1 p)
forall a. HasCallStack => a
undefined

instance GKdlAsset U1 where
  decodeKdl' :: forall (p :: k). RelativePath -> NodeListDecoder (U1 p)
decodeKdl' RelativePath
_ = U1 p -> DecodeArrow NodeList () (U1 p)
forall a. a -> DecodeArrow NodeList () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance (GKdlAsset f, GKdlAsset g) => GKdlAsset (f :*: g) where
  decodeKdl' :: forall (p :: k). RelativePath -> NodeListDecoder ((:*:) f g p)
decodeKdl' RelativePath
x = do
    a <- forall {k} (f :: k -> *) (p :: k).
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
forall (f :: k -> *) (p :: k).
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
decodeKdl' @f RelativePath
x
    b <- decodeKdl' @g x
    pure $ a :*: b

instance (KdlAsset a, KnownSymbol name) => GKdlAsset (M1 S (MetaSel (Just name) x y z) (K1 i a)) where
  decodeKdl' :: forall (p :: k).
RelativePath
-> NodeListDecoder (M1 S ('MetaSel ('Just name) x y z) (K1 i a) p)
decodeKdl' RelativePath
x = do
    let t :: RelativePath
t = String -> RelativePath
T.pack (String -> RelativePath) -> String -> RelativePath
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
    K1 i a p -> M1 S ('MetaSel ('Just name) x y z) (K1 i a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a p -> M1 S ('MetaSel ('Just name) x y z) (K1 i a) p)
-> (a -> K1 i a p)
-> a
-> M1 S ('MetaSel ('Just name) x y z) (K1 i a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S ('MetaSel ('Just name) x y z) (K1 i a) p)
-> DecodeArrow NodeList () a
-> DecodeArrow
     NodeList () (M1 S ('MetaSel ('Just name) x y z) (K1 i a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelativePath -> NodeDecodeArrow () a -> DecodeArrow NodeList () a
forall a b.
Typeable b =>
RelativePath -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
KDL.nodeWith RelativePath
t (RelativePath -> NodeDecodeArrow () a
forall a. KdlAsset a => RelativePath -> NodeDecoder a
decodeKdl RelativePath
x)

instance (GKdlAsset a) => GKdlAsset (D1 i a) where
  decodeKdl' :: forall (p :: k). RelativePath -> NodeListDecoder (D1 i a p)
decodeKdl' RelativePath
x = a p -> M1 D i a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a p -> M1 D i a p)
-> DecodeArrow NodeList () (a p)
-> DecodeArrow NodeList () (M1 D i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelativePath -> DecodeArrow NodeList () (a p)
forall (p :: k). RelativePath -> NodeListDecoder (a p)
forall {k} (f :: k -> *) (p :: k).
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
decodeKdl' RelativePath
x

instance {-# OVERLAPPABLE #-} (GKdlAsset a) => GKdlAsset (M1 C i a) where
  decodeKdl' :: forall (p :: k). RelativePath -> NodeListDecoder (M1 C i a p)
decodeKdl' RelativePath
x = a p -> M1 C i a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a p -> M1 C i a p)
-> DecodeArrow NodeList () (a p)
-> DecodeArrow NodeList () (M1 C i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelativePath -> DecodeArrow NodeList () (a p)
forall (p :: k). RelativePath -> NodeListDecoder (a p)
forall {k} (f :: k -> *) (p :: k).
GKdlAsset f =>
RelativePath -> NodeListDecoder (f p)
decodeKdl' RelativePath
x

instance (Asset a, Bundle a) => KdlAsset (AssetRef a) where
  decodeKdl :: RelativePath -> NodeDecoder (AssetRef a)
decodeKdl = ValueDecodeArrow () (AssetRef a) -> NodeDecoder (AssetRef a)
forall a b.
Typeable b =>
ValueDecodeArrow a b -> NodeDecodeArrow a b
KDL.argWith (ValueDecodeArrow () (AssetRef a) -> NodeDecoder (AssetRef a))
-> (RelativePath -> ValueDecodeArrow () (AssetRef a))
-> RelativePath
-> NodeDecoder (AssetRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePath -> ValueDecodeArrow () (AssetRef a)
forall a.
(Asset a, Bundle a) =>
RelativePath -> ValueDecoder (AssetRef a)
decodeRef

instance (KdlAsset a) => KdlAsset [a] where
  decodeKdl :: RelativePath -> NodeDecoder [a]
decodeKdl RelativePath
n = NodeListDecodeArrow () [a] -> NodeDecoder [a]
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
KDL.children (NodeListDecodeArrow () [a] -> NodeDecoder [a])
-> NodeListDecodeArrow () [a] -> NodeDecoder [a]
forall a b. (a -> b) -> a -> b
$ do
    x <- NodeDecodeArrow () a
-> NodeListDecodeArrow () (Map RelativePath [a])
forall a b.
Typeable b =>
NodeDecodeArrow a b -> NodeListDecodeArrow a (Map RelativePath [b])
KDL.remainingNodesWith (NodeDecodeArrow () a
 -> NodeListDecodeArrow () (Map RelativePath [a]))
-> NodeDecodeArrow () a
-> NodeListDecodeArrow () (Map RelativePath [a])
forall a b. (a -> b) -> a -> b
$ forall a. KdlAsset a => RelativePath -> NodeDecoder a
decodeKdl @a RelativePath
n
    pure $ concatMap snd $ Map.toList x

instance (KdlAsset a) => KdlAsset (KdlRef a) where
  decodeKdl :: RelativePath -> NodeDecoder (KdlRef a)
decodeKdl RelativePath
n = NodeDecoder (KdlRef a)
f1 NodeDecoder (KdlRef a)
-> NodeDecoder (KdlRef a) -> NodeDecoder (KdlRef a)
forall a.
DecodeArrow Node () a
-> DecodeArrow Node () a -> DecodeArrow Node () a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NodeDecoder (KdlRef a)
f2
    where
      f1 :: NodeDecoder (KdlRef a)
f1 = RelativePath
-> ValueDecodeArrow () (KdlRef a) -> NodeDecoder (KdlRef a)
forall a b.
Typeable b =>
RelativePath -> ValueDecodeArrow a b -> NodeDecodeArrow a b
KDL.propWith RelativePath
"link" (ValueDecodeArrow () (KdlRef a) -> NodeDecoder (KdlRef a))
-> ValueDecodeArrow () (KdlRef a) -> NodeDecoder (KdlRef a)
forall a b. (a -> b) -> a -> b
$ RelativePath -> ValueDecodeArrow () (KdlRef a)
forall a. RelativePath -> ValueDecoder (KdlRef a)
decodeKdlRef RelativePath
n
      f2 :: NodeDecoder (KdlRef a)
f2 = a -> KdlRef a
forall a. a -> KdlRef a
KdlValue (a -> KdlRef a) -> DecodeArrow Node () a -> NodeDecoder (KdlRef a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelativePath -> DecodeArrow Node () a
forall a. KdlAsset a => RelativePath -> NodeDecoder a
decodeKdl RelativePath
n

instance (KdlAsset a) => KdlAsset (KdlCollection a) where
  decodeKdl :: RelativePath -> NodeDecoder (KdlCollection a)
decodeKdl RelativePath
n = NodeListDecodeArrow () (KdlCollection a)
-> NodeDecoder (KdlCollection a)
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
KDL.children (NodeListDecodeArrow () (KdlCollection a)
 -> NodeDecoder (KdlCollection a))
-> NodeListDecodeArrow () (KdlCollection a)
-> NodeDecoder (KdlCollection a)
forall a b. (a -> b) -> a -> b
$ NodeDecoder a -> NodeListDecodeArrow () (KdlCollection a)
forall a.
Typeable a =>
NodeDecoder a -> NodeListDecoder (KdlCollection a)
colDecodeWith (NodeDecoder a -> NodeListDecodeArrow () (KdlCollection a))
-> NodeDecoder a -> NodeListDecodeArrow () (KdlCollection a)
forall a b. (a -> b) -> a -> b
$ forall a. KdlAsset a => RelativePath -> NodeDecoder a
decodeKdl @a RelativePath
n

instance {-# OVERLAPPABLE #-} (Typeable a, KDL.DecodeNode a) => KdlAsset a where
  decodeKdl :: RelativePath -> NodeDecoder a
decodeKdl RelativePath
_ = NodeDecoder a
forall a. DecodeNode a => NodeDecoder a
KDL.nodeDecoder

loadKdl :: forall a. (KdlAsset a) => Text -> FilePath -> RelativePath -> IO (Either Text a)
loadKdl :: forall a.
KdlAsset a =>
RelativePath
-> String -> RelativePath -> IO (Either RelativePath a)
loadKdl RelativePath
t String
p RelativePath
r = (DecodeError -> RelativePath)
-> Either DecodeError a -> Either RelativePath a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft DecodeError -> RelativePath
forall a. Show a => a -> RelativePath
T.show (Either DecodeError a -> Either RelativePath a)
-> IO (Either DecodeError a) -> IO (Either RelativePath a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DocumentDecoder a -> String -> IO (Either DecodeError a)
forall a. DocumentDecoder a -> String -> IO (Either DecodeError a)
KDL.decodeFileWith (NodeListDecoder a -> DocumentDecoder a
forall a. NodeListDecoder a -> DocumentDecoder a
KDL.document (NodeListDecoder a -> DocumentDecoder a)
-> NodeListDecoder a -> DocumentDecoder a
forall a b. (a -> b) -> a -> b
$ RelativePath -> NodeDecodeArrow () a -> NodeListDecoder a
forall a b.
Typeable b =>
RelativePath -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
KDL.nodeWith RelativePath
t (NodeDecodeArrow () a -> NodeListDecoder a)
-> NodeDecodeArrow () a -> NodeListDecoder a
forall a b. (a -> b) -> a -> b
$ forall a. KdlAsset a => RelativePath -> NodeDecoder a
decodeKdl @a RelativePath
r) String
p

decodeKdlRef :: RelativePath -> KDL.ValueDecoder (KdlRef a)
decodeKdlRef :: forall a. RelativePath -> ValueDecoder (KdlRef a)
decodeKdlRef RelativePath
path = do
  t <- forall a. DecodeValue a => ValueDecoder a
KDL.valueDecoder @Text
  pure $ KdlRef $ path <> "/" <> t

kdlToAssetRef :: (Asset a, Bundle a) => KdlRef a -> AssetRef a
kdlToAssetRef :: forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
kdlToAssetRef (KdlRef RelativePath
p) = RelativePath -> AssetRef a
forall a. (Asset a, Bundle a) => RelativePath -> AssetRef a
Ref RelativePath
p
kdlToAssetRef (KdlValue a
v) = a -> AssetRef a
forall a. a -> AssetRef a
PureRef a
v

instance ToAssetRef KdlRef where
  toRef :: forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
toRef = KdlRef a -> AssetRef a
forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
kdlToAssetRef