Serialisation.hs

{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  Games.ECS.Serialisation
-- Description : Generic XML Serialisation.
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Generic XML serialisation and deserialisation support. Adapted from the /generic-xmlpickler/ library, based on the /hxt/ package.
module Games.ECS.Serialisation
  ( XMLSerialise (..),
    XMLPickler (..),
    XMLPickleAsAttribute (..),
    Node,
    module Data.XML.Pickle,
    AsString (..),
    GXmlPickler (..),
    formatElement,
    AsList (..),
    optElem,
    optElemD,
    optElemC,
  )
where

import Control.Lens
import Data.Char (toLower)
import Data.Coerce
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HMS
import Data.HashSet (HashSet)
import Data.Hashable
import Data.Int
import Data.Interned
import Data.Interned.Text
import Data.Kind
import Data.Sequence (Seq)
import Data.Set.Ordered (OSet)
import Data.Set.Ordered qualified as OSet
import Data.String
import Data.Text (Text)
import Data.Word
import Data.XML.Pickle
import Data.XML.Types
import GHC.Exts
import GHC.Generics
import GHC.TypeLits

{--- | Serialise to QNames? It must be only a URI fragment.
data SerialisationIdentifier =
  SerialisationIdentifier {_identity :: URI}
                             deriving stock (Eq, Show, Generic)

makeLenses ''SerialisationIdentifier

-- | Serialise to IDREF?
data SerialisationReference =
  SerialisationReference {_reference :: URI}
                             deriving stock (Eq, Show, Generic)

makeLenses ''SerialisationReference
-}

-- | A convenience wrapper around an 'XMLPickler'.
class XMLSerialise a where
  {-# MINIMAL #-}

  -- | Serialise an /a/ as a named t'Element'.
  serialise :: String -> a -> Element
  {-# INLINE serialise #-}
  default serialise :: (XMLPickler [Node] a) => String -> a -> Element
  serialise n a = Element (fromString n) [] $ pickle (xpickle :: PU [Node] a) a

  -- | Deserialise a named t'Element'.
  deserialise :: String -> Element -> Either UnpickleError a
  {-# INLINE deserialise #-}
  default deserialise :: (XMLPickler [Node] a) => String -> Element -> Either UnpickleError a
  deserialise name (Element n _ a) | n == (fromString name) = unpickle (xpickle :: PU [Node] a) a
  deserialise name (Element n _ _) = Left $ ErrorMessage ("Error during unpickling: Expected " <> (fromString name) <> ", got " <> (fromString . show $ n))

instance (XMLPickler [Node] a) => XMLSerialise a where
  {-# INLINE serialise #-}
  serialise n a = Element (fromString n) [] $ pickle (xpickle :: PU [Node] a) a
  {-# INLINE deserialise #-}
  deserialise name (Element n _ a) | n == (fromString name) = unpickle (xpickle :: PU [Node] a) a
  deserialise name (Element n _ _) = Left $ ErrorMessage ("Error during unpickling: Expected " <> (fromString name) <> ", got " <> (fromString . show $ n))

-- | A lower-level pickler class.
class XMLPickler t a where
  -- | A combined pickler/unpickler.
  xpickle :: PU t a
  {-# INLINE xpickle #-}
  default xpickle :: (Generic a, GXmlPickler t (Rep a)) => PU t a
  xpickle = gpickle

-- | For when a type can be pickled as an XML 'Attribute'.
class XMLPickleAsAttribute a where
  pickleAsAttribute :: Name -> PU [Attribute] a

--  default pickleAsAttribute :: (forall a b. Coercible a b, XMLPickleAsAttribute b) => Name -> PU [Attribute] a
--  {-# INLINE pickleAsAttribute #-}
--  pickleAsAttribute name = xpWrap (coerce @a) (coerce :: _) (pickleAsAttribute name)

instance (XMLPickleAsAttribute a) => XMLPickleAsAttribute (Maybe a) where
  {-# INLINE pickleAsAttribute #-}
  pickleAsAttribute = xpOption . pickleAsAttribute

instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickleAsAttribute a where
  {-# INLINE pickleAsAttribute #-}
  pickleAsAttribute name = xpAttribute name xpPrim

-- | A deriving-via helper.
newtype AsString a = AsString {unAsString :: a} deriving newtype (Eq, Show, Read, IsString)

instance (IsString a, Show a) => XMLPickleAsAttribute (AsString a) where
  {-# INLINE pickleAsAttribute #-}
  pickleAsAttribute name = xpWrap (AsString . fromString) (show . unAsString) (pickleAsAttribute name)

deriving via (AsString InternedText) instance XMLPickleAsAttribute InternedText

{-# INLINE gpickle #-}

-- | A generic pickler.
gpickle :: forall t a. (Generic a, GXmlPickler t (Rep a)) => PU t a
gpickle = (xpWrap) (GHC.Generics.to @a) (GHC.Generics.from @a) (gxpicklef (gpickle @t @a))

-- | A deriving-via helper.
newtype AsList a = AsList {unAsList :: a} deriving (Show)

instance (IsList a) => IsList (AsList a) where
  type Item (AsList a) = Identity (Item a)
  {-# INLINE fromList #-}
  {-# INLINE toList #-}
  fromList = AsList . fromList . coerce
  toList = coerce . toList . unAsList

instance (IsList a, XMLPickler [Node] (Item a)) => XMLPickler [Node] (AsList a) where
  {-# INLINE xpickle #-}
  xpickle = ("AsList", "") <?+> (xpWrap (AsList . fromList) (toList . unAsList) $ xpAll xpickle) -- xpSeqWhile (xpIsolate xpickle))--{-xpSeqWhile-} xpFindMatches xpickle)

instance (Ord a, XMLPickler [Node] a) => XMLPickler [Node] (OSet a) where
  {-# INLINE xpickle #-}
  xpickle = ("OSet", "") <?+> (xpWrap OSet.fromList OSet.toAscList $ xpAll xpickle)

deriving via AsList (HashSet v) instance (Eq v, Hashable v, XMLPickler [Node] v) => XMLPickler [Node] (HashSet v)

deriving via AsList (Seq v) instance (XMLPickler [Node] v) => XMLPickler [Node] (Seq v)

instance {-# OVERLAPPABLE #-} (Eq k, Hashable k, XMLPickleAsAttribute k, XMLPickler [Node] v) => XMLPickler [Node] (HashMap k v) where
  {-# INLINE xpickle #-}
  xpickle =
    ("HashMap", "")
      <?+> ( xpWrap HMS.fromList HMS.toList $
               xpAll $
                 xpElem "li" (pickleAsAttribute "key") xpickle
           )

instance XMLPickler [Node] Word where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Word8 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Word16 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Word32 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Word64 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Natural where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Int where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Int8 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Int16 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Int32 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Int64 where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Integer where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] InternedText where
  {-# INLINE xpickle #-}
  xpickle = ("InternedText", "") <?+> (xpWrap intern unintern xpickle)

instance XMLPickler [Node] Float where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Double where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance XMLPickler [Node] Bool where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpBool

instance XMLPickler [Node] Text where
  {-# INLINE xpickle #-}
  xpickle = ("Text", "") <?+> xpContent (xpWrap (\t -> if t == "&#032;" then " " else t) (\t -> if t == " " then "&#032;" else t) xpId)

instance XMLPickler [Node] String where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpString

instance XMLPickler [Node] Char where
  {-# INLINE xpickle #-}
  xpickle = xpContent xpPrim

instance {-# OVERLAPPABLE #-} forall t a. (Generic a, GXmlPickler t (Rep a)) => XMLPickler t a where
  {-# INLINE xpickle #-}
  xpickle = gpickle

instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickler [Node] (AsString a) where
  {-# INLINE xpickle #-}
  xpickle = ("AsString", "") <?+> (xpWrap (AsString . read) (show . unAsString) (xpContent xpString))

instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickler Data.Text.Text a where
  {-# INLINE xpickle #-}
  xpickle = ("prim", "") <?+> xpPrim

-- TODO: Do parametric types.

-- | Generic pickling support.
class GXmlPickler t f where
  gxpicklef :: PU t a -> PU t (f a)
  {-# INLINE gxpicklef #-}
  gxpicklef = gxpickleContentsf
  gxpickleContentsf :: PU t a -> PU t (f a)

-- | For individual fields
instance (XMLPickler t a) => GXmlPickler t (K1 i a) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf _ = xpWrap K1 unK1 xpickle

-- | For empty constructors
instance GXmlPickler [t] U1 where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf _ = xpWrap (const U1) (const ()) xpUnit

-- | For products of fields
instance (GXmlPickler [t] f, GXmlPickler [t] g) => GXmlPickler [t] (f :*: g) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf f = xpWrap (uncurry (:*:)) (\(a :*: b) -> (a, b)) (gxpicklef f `xpPair` gxpicklef f)

-- | For sums of constructors
instance (GXmlPickler t f, GXmlPickler t g) => GXmlPickler t (f :+: g) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf f = xpMayFail ((xpMayFail (gxpicklef f)) `xpSum` (xpMayFail (gxpicklef f)))

-- | For datatypes
instance {-# OVERLAPPABLE #-} (Datatype d, GXmlPickler t f) => GXmlPickler t (M1 D d f) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf f = (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap M1 unM1 (gxpicklef f))

-- | For constructors
instance {-# OVERLAPPABLE #-} (Constructor c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 C c f) where
  {-# INLINE gxpickleContentsf #-}
  {-# INLINE gxpicklef #-}
  gxpicklef f = xpElemNodes (fromString . formatElement $ conName (undefined :: M1 C c f p)) (gxpickleContentsf f)
  gxpickleContentsf f = (xpWrap M1 unM1 (gxpicklef f))

-- | For record field selectors
instance {-# OVERLAPPABLE #-} (Selector c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 S c f) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf f = optElem (xpWrap M1 unM1 (gxpicklef f)) (undefined :: M1 S c f p)

-- | For Maybe types
instance {-# OVERLAPPING #-} (XMLPickler [Node] a, Selector c) => GXmlPickler [Node] (M1 S c (K1 i (Maybe a))) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf _ = xpWrap (M1 . K1) (unK1 . unM1) (xpOption $ optElem xpickle (undefined :: M1 S c f p))

{--- | An instance for types with a single constructor. Don't bother with the constructor; just the datafields.
instance {-# OVERLAPPING #-} (Constructor c'', GXmlPickler [Node] g, GXmlPickler [Node] h, Datatype d, GXmlPickler [Node] f,  Datatype d, ty ~ (M1 D d (M1 C c'' f)), f ~ (g :*: h)) => GXmlPickler [Node] (M1 D d (M1 C c'' (g :*: h))) where
  {-# INLINE gxpickleContentsf #-}
  --gxpicklef f = xpElemNodes (fromString . formatElement $ conName (undefined :: M1 C c'' f p)) (gxpickleContentsf f)
  gxpickleContentsf f =  (fromString $ datatypeName (undefined :: ty p), "") <?+>  (xpWrap (M1 . M1 . uncurry (:*:)  ) ( (\(a :*: b) -> (a, b)) . unM1 . unM1) (gxpicklef f `xpPair` gxpicklef f))
-}
{--- | An instance for wrapper datatypes/newtypes. Don't bother with the wrapper constructor or fieldname; just the wrapped data.
instance {-# OVERLAPPING #-} ( XMLPickler [Node] a,  Datatype d, ty ~ (M1 D d (M1 C c'' (M1 S c (K1 i a))))) => GXmlPickler [Node] (M1 D d (M1 C c'' (M1 S c (K1 i a)))) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf f = {-xpElemNodes (fromString . formatElement $ datatypeName (undefined :: ty p))-} (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap (M1 . M1 . M1 . K1) (unK1 . unM1 . unM1 . unM1) (xpickle))-}

{-# INLINE xpSum #-}

-- | Pickle adapter for ':+:'
xpSum :: PU t (f r) -> PU t (g r) -> PU t ((f :+: g) r)
xpSum l r = xpWrap i o (xpEither l r)
  where
    i (Left x) = L1 x
    i (Right x) = R1 x
    o (L1 x) = Left x
    o (R1 x) = Right x

-- | Pickle adapter for 'Datatype'
{-# INLINE optElemD #-}
optElemD :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Datatype s) => PU [Node] a -> t i s f p -> PU [Node] a
optElemD x y = case formatElement (datatypeName y) of
  "" -> x
  n -> xpElemNodes (fromString n) x

-- | Pickle adapter for 'Constructor'
{-# INLINE optElemC #-}
optElemC :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Constructor s) => PU [Node] a -> t i s f p -> PU [Node] a
optElemC x y = case formatElement (conName y) of
  "" -> x
  n -> xpElemNodes (fromString n) x

-- | Pickle adapter for 'Selector'
{-# INLINE optElem #-}
optElem :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Selector s) => PU [Node] a -> t i s f p -> PU [Node] a
optElem x y = case formatElement (selName y) of
  "" -> x
  n -> xpElemNodes (fromString n) x

-- | Format field names nicely
{-# INLINE formatElement #-}
formatElement :: String -> String
formatElement = headToLower . stripLeadingAndTrailingUnderscore

{-# INLINE headToLower #-}
headToLower :: String -> String
headToLower l = case l of
  [] -> []
  (x : xs) -> toLower x : xs

{-# INLINE stripLeadingAndTrailingUnderscore #-}
stripLeadingAndTrailingUnderscore :: String -> String
stripLeadingAndTrailingUnderscore = stripLeadingUnderscore . stripTrailingUnderscore

{-# INLINE stripLeadingUnderscore #-}
stripLeadingUnderscore :: String -> String
stripLeadingUnderscore s = case s of
  ('_' : ls) -> ls
  ls -> ls

{-# INLINE stripTrailingUnderscore #-}
stripTrailingUnderscore :: String -> String
stripTrailingUnderscore s = case s of
  "" -> ""
  [x, '_'] -> [x]
  (x : xs) -> x : stripTrailingUnderscore xs