Kdl.hs

{-# 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 x = KDL.children (to <$> decodeKdl' @(Rep a) x)

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

data KdlRef a = KdlRef Text | KdlValue a deriving (Show)

instance GKdlAsset V1 where
  decodeKdl' _ = undefined

instance GKdlAsset U1 where
  decodeKdl' _ = pure U1

instance (GKdlAsset f, GKdlAsset g) => GKdlAsset (f :*: g) where
  decodeKdl' x = do
    a <- decodeKdl' @f 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' x = do
    let t = T.pack $ symbolVal (Proxy @name)
    M1 . K1 <$> KDL.nodeWith t (decodeKdl x)

instance (GKdlAsset a) => GKdlAsset (D1 i a) where
  decodeKdl' x = M1 <$> decodeKdl' x

instance {-# OVERLAPPABLE #-} (GKdlAsset a) => GKdlAsset (M1 C i a) where
  decodeKdl' x = M1 <$> decodeKdl' x

instance (Asset a, Bundle a) => KdlAsset (AssetRef a) where
  decodeKdl = KDL.argWith . decodeRef

instance (KdlAsset a) => KdlAsset [a] where
  decodeKdl n = KDL.children $ do
    x <- KDL.remainingNodesWith $ decodeKdl @a n
    pure $ concatMap snd $ Map.toList x

instance (KdlAsset a) => KdlAsset (KdlRef a) where
  decodeKdl n = f1 <|> f2
    where
      f1 = KDL.propWith "link" $ decodeKdlRef n
      f2 = KdlValue <$> decodeKdl n

instance (KdlAsset a) => KdlAsset (KdlCollection a) where
  decodeKdl n = KDL.children $ colDecodeWith $ decodeKdl @a n

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

loadKdl :: forall a. (KdlAsset a) => Text -> FilePath -> RelativePath -> IO (Either Text a)
loadKdl t p r = mapLeft T.show <$> KDL.decodeFileWith (KDL.document $ KDL.nodeWith t $ decodeKdl @a r) p

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

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

instance ToAssetRef KdlRef where
  toRef = kdlToAssetRef