{-# 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 :: forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Element
serialiseEntity worldType 'Individual
ent = String -> worldType 'Individual -> Element
forall a. XMLSerialise a => String -> a -> Element
serialise String
"individual" worldType 'Individual
ent

{-# INLINEABLE deserialiseEntity #-}

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

{-# INLINEABLE entityPickler #-}

-- | A pickler for individuals.
entityPickler :: (XMLSerialise (worldType Individual), XMLPickler [Node] (worldType Individual)) => PU [Element] (worldType Individual)
entityPickler :: forall (worldType :: Access -> *).
(XMLSerialise (worldType 'Individual),
 XMLPickler [Node] (worldType 'Individual)) =>
PU [Element] (worldType 'Individual)
entityPickler = ([Element] -> UnpickleResult [Element] (worldType 'Individual))
-> (worldType 'Individual -> [Element])
-> PU [Element] (worldType 'Individual)
forall t a. (t -> UnpickleResult t a) -> (a -> t) -> PU t a
PU (PU [Element] (worldType 'Individual)
-> [Element] -> UnpickleResult [Element] (worldType 'Individual)
forall t a. PU t a -> t -> UnpickleResult t a
unpickleTree (PU [Node] (worldType 'Individual)
-> PU [Element] (worldType 'Individual)
forall a. PU [Node] a -> PU [Element] a
xpUnliftElems (Name
-> PU [Node] (worldType 'Individual)
-> PU [Node] (worldType 'Individual)
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes Name
"individual" PU [Node] (worldType 'Individual)
forall t a. XMLPickler t a => PU t a
xpickle))) ((Element -> [Element])
-> (worldType 'Individual -> Element)
-> worldType 'Individual
-> [Element]
forall a b.
(a -> b)
-> (worldType 'Individual -> a) -> worldType 'Individual -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: []) worldType 'Individual -> Element
forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Element
serialiseEntity)

-- | A pickler for worlds.
{-# INLINEABLE worldPickler #-}
worldPickler :: (World worldType, XMLSerialise (worldType Individual)) => PU [Node] (worldType Storing)
worldPickler :: forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
PU [Node] (worldType 'Storing)
worldPickler = ([Node] -> Maybe (worldType 'Storing))
-> (worldType 'Storing -> [Node])
-> PU [Node] [Node]
-> PU [Node] (worldType 'Storing)
forall a b t. (a -> Maybe b) -> (b -> a) -> PU t a -> PU t b
xpWrapMaybe (Element -> Maybe (worldType 'Storing)
forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
Element -> Maybe (worldType 'Storing)
deserialiseWorld (Element -> Maybe (worldType 'Storing))
-> ([Node] -> Element) -> [Node] -> Maybe (worldType 'Storing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[NodeElement Element
e] -> Element
e)) ((\Element
e -> [Element -> Node
NodeElement Element
e]) (Element -> [Node])
-> (worldType 'Storing -> Element) -> worldType 'Storing -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. worldType 'Storing -> Element
forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
worldType 'Storing -> Element
serialiseWorld) PU [Node] [Node]
forall a. PU a a
xpId

-- | Serialise a world as an XML t'Element'.
{-# INLINEABLE serialiseWorld #-}
serialiseWorld :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Element
serialiseWorld :: forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
worldType 'Storing -> Element
serialiseWorld worldType 'Storing
world = Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
"world" [] {-TODO: Put number of entities etc here for corruption detection -} [Node]
serialisedCritters
  where
    serialisedCritters :: [Node]
serialisedCritters = (worldType 'Individual -> Node)
-> [worldType 'Individual] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Element -> Node
NodeElement (Element -> Node)
-> (worldType 'Individual -> Element)
-> worldType 'Individual
-> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. worldType 'Individual -> Element
forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Element
serialiseEntity) (worldType 'Storing
world worldType 'Storing
-> Getting
     (Endo [worldType 'Individual])
     (worldType 'Storing)
     (worldType 'Individual)
-> [worldType 'Individual]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting
  (Endo [worldType 'Individual])
  (worldType 'Storing)
  (worldType 'Individual)
IndexedTraversal'
  Entity (worldType 'Storing) (worldType 'Individual)
forall (w :: Access -> *).
World w =>
IndexedTraversal' Entity (w 'Storing) (w 'Individual)
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 :: forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
Element -> Maybe (worldType 'Storing)
deserialiseWorld (Element Name
"world" [] [Node]
ns) = worldType 'Storing -> Maybe (worldType 'Storing)
forall a. a -> Maybe a
Just worldType 'Storing
world
  where
    deserialisedCritters :: [worldType 'Individual]
deserialisedCritters = (Node -> Maybe (worldType 'Individual))
-> [Node] -> [worldType 'Individual]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(NodeElement Element
elmt) -> Element -> Maybe (worldType 'Individual)
forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
Element -> Maybe (worldType 'Individual)
deserialiseEntity Element
elmt) [Node]
ns
    world :: worldType 'Storing
world = (worldType 'Individual -> worldType 'Storing -> worldType 'Storing)
-> worldType 'Storing
-> [worldType 'Individual]
-> worldType 'Storing
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr worldType 'Individual -> worldType 'Storing -> worldType 'Storing
forall (w :: Access -> *).
World w =>
w 'Individual -> w 'Storing -> w 'Storing
storeEntity worldType 'Storing
forall (w :: Access -> *). World w => w 'Storing
newWorld [worldType 'Individual]
deserialisedCritters
deserialiseWorld Element
_ = Maybe (worldType 'Storing)
forall a. Maybe a
Nothing

-- | Serialise an individual to an XML t'Document'.
entityToXMLDoc :: (XMLSerialise (worldType Individual)) => worldType Individual -> Document
entityToXMLDoc :: forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Document
entityToXMLDoc worldType 'Individual
ent = Prologue -> Element -> [Miscellaneous] -> Document
Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) (worldType 'Individual -> Element
forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Element
serialiseEntity worldType 'Individual
ent) []

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

-- | Pretty-print an individual as formatted XML.
renderEntityAsXML :: (XMLSerialise (worldType Individual)) => worldType Individual -> Text
renderEntityAsXML :: forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Text
renderEntityAsXML worldType 'Individual
ent = let (Right Document
doc) = Document -> Either (Set Text) Document
TX.fromXMLDocument (worldType 'Individual -> Document
forall (worldType :: Access -> *).
XMLSerialise (worldType 'Individual) =>
worldType 'Individual -> Document
entityToXMLDoc worldType 'Individual
ent) in LazyText -> Text
toStrict (LazyText -> Text) -> LazyText -> Text
forall a b. (a -> b) -> a -> b
$ RenderSettings -> Document -> LazyText
TX.renderText RenderSettings
forall a. Default a => a
TX.def Document
doc

-- | Pretty-print a world as formatted XML.
renderWorldAsXML :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Text
renderWorldAsXML :: forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
worldType 'Storing -> Text
renderWorldAsXML worldType 'Storing
world = let (Right Document
doc) = Document -> Either (Set Text) Document
TX.fromXMLDocument (worldType 'Storing -> Document
forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
worldType 'Storing -> Document
worldToXMLDoc worldType 'Storing
world) in LazyText -> Text
toStrict (LazyText -> Text) -> LazyText -> Text
forall a b. (a -> b) -> a -> b
$ RenderSettings -> Document -> LazyText
TX.renderText RenderSettings
forall a. Default a => a
TX.def Document
doc

-- | Serialise a world to an XML file.
writeWorldToFile :: (World worldType, XMLSerialise (worldType Individual)) => FilePath -> worldType Storing -> IO ()
writeWorldToFile :: forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
String -> worldType 'Storing -> IO ()
writeWorldToFile String
path worldType 'Storing
world = let (Right Document
doc) = Document -> Either (Set Text) Document
TX.fromXMLDocument (worldType 'Storing -> Document
forall (worldType :: Access -> *).
(World worldType, XMLSerialise (worldType 'Individual)) =>
worldType 'Storing -> Document
worldToXMLDoc worldType 'Storing
world) in RenderSettings -> String -> Document -> IO ()
TX.writeFile (RenderSettings
forall a. Default a => a
TX.def {TX.rsPretty = True}) String
path Document
doc