SaveLoad.hs

{-# OPTIONS_GHC -fno-ignore-asserts #-}

-- |
-- Module      :  Games.ECS.SaveLoad
-- Description : Saving and loading support for worlds and individuals.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Saving and loading support, built upon 'Games.ECS.Serialisation'.
module Games.ECS.SaveLoad
  ( entityToXMLDoc,
    worldToXMLDoc,
    renderEntityAsXML,
    renderWorldAsXML,
    writeWorldToFile,
    serialiseWorld,
    deserialiseWorld,
    entityPickler,
    worldPickler,
  )
where

import Control.Lens
import Data.Maybe
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Data.XML.Pickle
import Data.XML.Types
import Games.ECS.Serialisation
import Games.ECS.World
import Text.XML qualified as TX

{-# INLINEABLE serialiseEntity #-}

-- | Serialises an individual in an "individual" XML t'Element'.
serialiseEntity :: (XMLSerialise (worldType Individual)) => worldType Individual -> Element
serialiseEntity ent = serialise "individual" ent

{-# INLINEABLE deserialiseEntity #-}

-- | Deserialises an individual in an "individual" XML t'Element'.
deserialiseEntity :: (XMLSerialise (worldType Individual)) => Element -> Maybe (worldType Individual)
deserialiseEntity elmt = case deserialise "individual" elmt of
  Right a -> Just a
  Left a -> error (ppUnpickleError a) -- Nothing

{-# INLINEABLE entityPickler #-}

-- | A pickler for individuals.
entityPickler :: (XMLSerialise (worldType Individual), XMLPickler [Node] (worldType Individual)) => PU [Element] (worldType Individual)
entityPickler = PU (unpickleTree (xpUnliftElems (xpElemNodes "individual" xpickle))) (fmap (: []) serialiseEntity)

-- | A pickler for worlds.
{-# INLINEABLE worldPickler #-}
worldPickler :: (World worldType, XMLSerialise (worldType Individual)) => PU [Node] (worldType Storing)
worldPickler = xpWrapMaybe (deserialiseWorld . (\[NodeElement e] -> e)) ((\e -> [NodeElement e]) . serialiseWorld) xpId

-- | Serialise a world as an XML t'Element'.
{-# INLINEABLE serialiseWorld #-}
serialiseWorld :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Element
serialiseWorld world = Element "world" [] {-TODO: Put number of entities etc here for corruption detection -} serialisedCritters
  where
    serialisedCritters = fmap (NodeElement . serialiseEntity) (world ^.. entities)

-- TODO: Optimise this. It's going to be slow cus of cache thrashing.

-- | Deserialise a world from an XML t'Element'.
deserialiseWorld :: (World worldType, XMLSerialise (worldType Individual)) => Element -> Maybe (worldType Storing)
deserialiseWorld (Element "world" [] ns) = Just world
  where
    deserialisedCritters = mapMaybe (\(NodeElement elmt) -> deserialiseEntity elmt) ns
    world = foldr storeEntity newWorld deserialisedCritters
deserialiseWorld _ = Nothing

-- | Serialise an individual to an XML t'Document'.
entityToXMLDoc :: (XMLSerialise (worldType Individual)) => worldType Individual -> Document
entityToXMLDoc ent = Document (Prologue [] Nothing []) (serialiseEntity ent) []

-- | Serialise a world to an XML t'Document'.
worldToXMLDoc :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Document
worldToXMLDoc world = Document (Prologue [] Nothing []) (serialiseWorld world) []

-- | Pretty-print an individual as formatted XML.
renderEntityAsXML :: (XMLSerialise (worldType Individual)) => worldType Individual -> Text
renderEntityAsXML ent = let (Right doc) = TX.fromXMLDocument (entityToXMLDoc ent) in toStrict $ TX.renderText TX.def doc

-- | Pretty-print a world as formatted XML.
renderWorldAsXML :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Text
renderWorldAsXML world = let (Right doc) = TX.fromXMLDocument (worldToXMLDoc world) in toStrict $ TX.renderText TX.def doc

-- | Serialise a world to an XML file.
writeWorldToFile :: (World worldType, XMLSerialise (worldType Individual)) => FilePath -> worldType Storing -> IO ()
writeWorldToFile path world = let (Right doc) = TX.fromXMLDocument (worldToXMLDoc world) in TX.writeFile (TX.def {TX.rsPretty = True}) path doc