{-# 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 String
n a
a = Name -> [(Name, [Content])] -> [Node] -> Element
Element (String -> Name
forall a. IsString a => String -> a
fromString String
n) [] ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ PU [Node] a -> a -> [Node]
forall t a. PU t a -> a -> t
pickle (PU [Node] a
forall t a. XMLPickler t a => PU t a
xpickle :: PU [Node] a) 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 String
name (Element Name
n [(Name, [Content])]
_ [Node]
a) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> Name
forall a. IsString a => String -> a
fromString String
name) = PU [Node] a -> [Node] -> Either UnpickleError a
forall t a. PU t a -> t -> Either UnpickleError a
unpickle (PU [Node] a
forall t a. XMLPickler t a => PU t a
xpickle :: PU [Node] a) [Node]
a
  deserialise String
name (Element Name
n [(Name, [Content])]
_ [Node]
_) = UnpickleError -> Either UnpickleError a
forall a b. a -> Either a b
Left (UnpickleError -> Either UnpickleError a)
-> UnpickleError -> Either UnpickleError a
forall a b. (a -> b) -> a -> b
$ Text -> UnpickleError
ErrorMessage (Text
"Error during unpickling: Expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString String
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
n))

instance (XMLPickler [Node] a) => XMLSerialise a where
  {-# INLINE serialise #-}
  serialise :: String -> a -> Element
serialise String
n a
a = Name -> [(Name, [Content])] -> [Node] -> Element
Element (String -> Name
forall a. IsString a => String -> a
fromString String
n) [] ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ PU [Node] a -> a -> [Node]
forall t a. PU t a -> a -> t
pickle (PU [Node] a
forall t a. XMLPickler t a => PU t a
xpickle :: PU [Node] a) a
a
  {-# INLINE deserialise #-}
  deserialise :: String -> Element -> Either UnpickleError a
deserialise String
name (Element Name
n [(Name, [Content])]
_ [Node]
a) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> Name
forall a. IsString a => String -> a
fromString String
name) = PU [Node] a -> [Node] -> Either UnpickleError a
forall t a. PU t a -> t -> Either UnpickleError a
unpickle (PU [Node] a
forall t a. XMLPickler t a => PU t a
xpickle :: PU [Node] a) [Node]
a
  deserialise String
name (Element Name
n [(Name, [Content])]
_ [Node]
_) = UnpickleError -> Either UnpickleError a
forall a b. a -> Either a b
Left (UnpickleError -> Either UnpickleError a)
-> UnpickleError -> Either UnpickleError a
forall a b. (a -> b) -> a -> b
$ Text -> UnpickleError
ErrorMessage (Text
"Error during unpickling: Expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString String
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
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 = PU t a
forall t a. (Generic a, GXmlPickler t (Rep a)) => PU t a
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 :: Name -> PU [(Name, [Content])] (Maybe a)
pickleAsAttribute = PU [(Name, [Content])] a -> PU [(Name, [Content])] (Maybe a)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [(Name, [Content])] a -> PU [(Name, [Content])] (Maybe a))
-> (Name -> PU [(Name, [Content])] a)
-> Name
-> PU [(Name, [Content])] (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PU [(Name, [Content])] a
forall a.
XMLPickleAsAttribute a =>
Name -> PU [(Name, [Content])] a
pickleAsAttribute

instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickleAsAttribute a where
  {-# INLINE pickleAsAttribute #-}
  pickleAsAttribute :: Name -> PU [(Name, [Content])] a
pickleAsAttribute Name
name = Name -> PU Text a -> PU [(Name, [Content])] a
forall a. Name -> PU Text a -> PU [(Name, [Content])] a
xpAttribute Name
name PU Text a
forall a. (Show a, Read a) => PU Text a
xpPrim

-- | A deriving-via helper.
newtype AsString a = AsString {forall a. AsString a -> a
unAsString :: a} deriving newtype (AsString a -> AsString a -> Bool
(AsString a -> AsString a -> Bool)
-> (AsString a -> AsString a -> Bool) -> Eq (AsString a)
forall a. Eq a => AsString a -> AsString a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => AsString a -> AsString a -> Bool
== :: AsString a -> AsString a -> Bool
$c/= :: forall a. Eq a => AsString a -> AsString a -> Bool
/= :: AsString a -> AsString a -> Bool
Eq, Int -> AsString a -> ShowS
[AsString a] -> ShowS
AsString a -> String
(Int -> AsString a -> ShowS)
-> (AsString a -> String)
-> ([AsString a] -> ShowS)
-> Show (AsString a)
forall a. Show a => Int -> AsString a -> ShowS
forall a. Show a => [AsString a] -> ShowS
forall a. Show a => AsString a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AsString a -> ShowS
showsPrec :: Int -> AsString a -> ShowS
$cshow :: forall a. Show a => AsString a -> String
show :: AsString a -> String
$cshowList :: forall a. Show a => [AsString a] -> ShowS
showList :: [AsString a] -> ShowS
Show, ReadPrec [AsString a]
ReadPrec (AsString a)
Int -> ReadS (AsString a)
ReadS [AsString a]
(Int -> ReadS (AsString a))
-> ReadS [AsString a]
-> ReadPrec (AsString a)
-> ReadPrec [AsString a]
-> Read (AsString a)
forall a. Read a => ReadPrec [AsString a]
forall a. Read a => ReadPrec (AsString a)
forall a. Read a => Int -> ReadS (AsString a)
forall a. Read a => ReadS [AsString a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (AsString a)
readsPrec :: Int -> ReadS (AsString a)
$creadList :: forall a. Read a => ReadS [AsString a]
readList :: ReadS [AsString a]
$creadPrec :: forall a. Read a => ReadPrec (AsString a)
readPrec :: ReadPrec (AsString a)
$creadListPrec :: forall a. Read a => ReadPrec [AsString a]
readListPrec :: ReadPrec [AsString a]
Read, String -> AsString a
(String -> AsString a) -> IsString (AsString a)
forall a. IsString a => String -> AsString a
forall a. (String -> a) -> IsString a
$cfromString :: forall a. IsString a => String -> AsString a
fromString :: String -> AsString a
IsString)

instance (IsString a, Show a) => XMLPickleAsAttribute (AsString a) where
  {-# INLINE pickleAsAttribute #-}
  pickleAsAttribute :: Name -> PU [(Name, [Content])] (AsString a)
pickleAsAttribute Name
name = (String -> AsString a)
-> (AsString a -> String)
-> PU [(Name, [Content])] String
-> PU [(Name, [Content])] (AsString a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (a -> AsString a
forall a. a -> AsString a
AsString (a -> AsString a) -> (String -> a) -> String -> AsString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString) (a -> String
forall a. Show a => a -> String
show (a -> String) -> (AsString a -> a) -> AsString a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsString a -> a
forall a. AsString a -> a
unAsString) (Name -> PU [(Name, [Content])] String
forall a.
XMLPickleAsAttribute a =>
Name -> PU [(Name, [Content])] a
pickleAsAttribute Name
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 :: forall t a. (Generic a, GXmlPickler t (Rep a)) => PU t a
gpickle = (forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap) (forall a x. Generic a => Rep a x -> a
GHC.Generics.to @a) (forall a x. Generic a => a -> Rep a x
GHC.Generics.from @a) (PU t a -> PU t (Rep a a)
forall a. PU t a -> PU t (Rep a a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
gxpicklef (forall t a. (Generic a, GXmlPickler t (Rep a)) => PU t a
gpickle @t @a))

-- | A deriving-via helper.
newtype AsList a = AsList {forall a. AsList a -> a
unAsList :: a} deriving (Int -> AsList a -> ShowS
[AsList a] -> ShowS
AsList a -> String
(Int -> AsList a -> ShowS)
-> (AsList a -> String) -> ([AsList a] -> ShowS) -> Show (AsList a)
forall a. Show a => Int -> AsList a -> ShowS
forall a. Show a => [AsList a] -> ShowS
forall a. Show a => AsList a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AsList a -> ShowS
showsPrec :: Int -> AsList a -> ShowS
$cshow :: forall a. Show a => AsList a -> String
show :: AsList a -> String
$cshowList :: forall a. Show a => [AsList a] -> ShowS
showList :: [AsList a] -> ShowS
Show)

instance (IsList a) => IsList (AsList a) where
  type Item (AsList a) = Identity (Item a)
  {-# INLINE fromList #-}
  {-# INLINE toList #-}
  fromList :: [Item (AsList a)] -> AsList a
fromList = a -> AsList a
forall a. a -> AsList a
AsList (a -> AsList a)
-> ([Identity (Item a)] -> a) -> [Identity (Item a)] -> AsList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item a] -> a
forall l. IsList l => [Item l] -> l
fromList ([Item a] -> a)
-> ([Identity (Item a)] -> [Item a]) -> [Identity (Item a)] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identity (Item a)] -> [Item a]
forall a b. Coercible a b => a -> b
coerce
  toList :: AsList a -> [Item (AsList a)]
toList = [Item a] -> [Identity (Item a)]
forall a b. Coercible a b => a -> b
coerce ([Item a] -> [Identity (Item a)])
-> (AsList a -> [Item a]) -> AsList a -> [Identity (Item a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Item a]
forall l. IsList l => l -> [Item l]
toList (a -> [Item a]) -> (AsList a -> a) -> AsList a -> [Item a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsList a -> a
forall a. AsList a -> a
unAsList

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

instance (Ord a, XMLPickler [Node] a) => XMLPickler [Node] (OSet a) where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] (OSet a)
xpickle = (Text
"OSet", Text
"") (Text, Text) -> PU [Node] (OSet a) -> PU [Node] (OSet a)
forall t a. (Text, Text) -> PU t a -> PU t a
<?+> (([a] -> OSet a)
-> (OSet a -> [a]) -> PU [Node] [a] -> PU [Node] (OSet a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap [a] -> OSet a
forall a. Ord a => [a] -> OSet a
OSet.fromList OSet a -> [a]
forall a. OSet a -> [a]
OSet.toAscList (PU [Node] [a] -> PU [Node] (OSet a))
-> PU [Node] [a] -> PU [Node] (OSet a)
forall a b. (a -> b) -> a -> b
$ PU [Node] a -> PU [Node] [a]
forall a b. PU [a] b -> PU [a] [b]
xpAll PU [Node] a
forall t a. XMLPickler t a => PU t a
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 :: PU [Node] (HashMap k v)
xpickle =
    (Text
"HashMap", Text
"")
      (Text, Text) -> PU [Node] (HashMap k v) -> PU [Node] (HashMap k v)
forall t a. (Text, Text) -> PU t a -> PU t a
<?+> ( ([(k, v)] -> HashMap k v)
-> (HashMap k v -> [(k, v)])
-> PU [Node] [(k, v)]
-> PU [Node] (HashMap k v)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMS.fromList HashMap k v -> [(k, v)]
forall k v. HashMap k v -> [(k, v)]
HMS.toList (PU [Node] [(k, v)] -> PU [Node] (HashMap k v))
-> PU [Node] [(k, v)] -> PU [Node] (HashMap k v)
forall a b. (a -> b) -> a -> b
$
               PU [Node] (k, v) -> PU [Node] [(k, v)]
forall a b. PU [a] b -> PU [a] [b]
xpAll (PU [Node] (k, v) -> PU [Node] [(k, v)])
-> PU [Node] (k, v) -> PU [Node] [(k, v)]
forall a b. (a -> b) -> a -> b
$
                 Name -> PU [(Name, [Content])] k -> PU [Node] v -> PU [Node] (k, v)
forall a n.
Name -> PU [(Name, [Content])] a -> PU [Node] n -> PU [Node] (a, n)
xpElem Name
"li" (Name -> PU [(Name, [Content])] k
forall a.
XMLPickleAsAttribute a =>
Name -> PU [(Name, [Content])] a
pickleAsAttribute Name
"key") PU [Node] v
forall t a. XMLPickler t a => PU t a
xpickle
           )

instance XMLPickler [Node] Word where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Word
xpickle = PU Text Word -> PU [Node] Word
forall a. PU Text a -> PU [Node] a
xpContent PU Text Word
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Word8 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Word8
xpickle = PU Text Word8 -> PU [Node] Word8
forall a. PU Text a -> PU [Node] a
xpContent PU Text Word8
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Word16 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Word16
xpickle = PU Text Word16 -> PU [Node] Word16
forall a. PU Text a -> PU [Node] a
xpContent PU Text Word16
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Word32 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Word32
xpickle = PU Text Word32 -> PU [Node] Word32
forall a. PU Text a -> PU [Node] a
xpContent PU Text Word32
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Word64 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Word64
xpickle = PU Text Word64 -> PU [Node] Word64
forall a. PU Text a -> PU [Node] a
xpContent PU Text Word64
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Natural where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Natural
xpickle = PU Text Natural -> PU [Node] Natural
forall a. PU Text a -> PU [Node] a
xpContent PU Text Natural
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Int where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Int
xpickle = PU Text Int -> PU [Node] Int
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Int8 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Int8
xpickle = PU Text Int8 -> PU [Node] Int8
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int8
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Int16 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Int16
xpickle = PU Text Int16 -> PU [Node] Int16
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int16
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Int32 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Int32
xpickle = PU Text Int32 -> PU [Node] Int32
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int32
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Int64 where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Int64
xpickle = PU Text Int64 -> PU [Node] Int64
forall a. PU Text a -> PU [Node] a
xpContent PU Text Int64
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Integer where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Integer
xpickle = PU Text Integer -> PU [Node] Integer
forall a. PU Text a -> PU [Node] a
xpContent PU Text Integer
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] InternedText where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] InternedText
xpickle = (Text
"InternedText", Text
"") (Text, Text) -> PU [Node] InternedText -> PU [Node] InternedText
forall t a. (Text, Text) -> PU t a -> PU t a
<?+> ((Text -> InternedText)
-> (InternedText -> Text)
-> PU [Node] Text
-> PU [Node] InternedText
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap Uninterned InternedText -> InternedText
Text -> InternedText
forall t. Interned t => Uninterned t -> t
intern InternedText -> Uninterned InternedText
InternedText -> Text
forall t. Uninternable t => t -> Uninterned t
unintern PU [Node] Text
forall t a. XMLPickler t a => PU t a
xpickle)

instance XMLPickler [Node] Float where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Float
xpickle = PU Text Float -> PU [Node] Float
forall a. PU Text a -> PU [Node] a
xpContent PU Text Float
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Double where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Double
xpickle = PU Text Double -> PU [Node] Double
forall a. PU Text a -> PU [Node] a
xpContent PU Text Double
forall a. (Show a, Read a) => PU Text a
xpPrim

instance XMLPickler [Node] Bool where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Bool
xpickle = PU Text Bool -> PU [Node] Bool
forall a. PU Text a -> PU [Node] a
xpContent PU Text Bool
xpBool

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

instance XMLPickler [Node] String where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] String
xpickle = PU Text String -> PU [Node] String
forall a. PU Text a -> PU [Node] a
xpContent PU Text String
xpString

instance XMLPickler [Node] Char where
  {-# INLINE xpickle #-}
  xpickle :: PU [Node] Char
xpickle = PU Text Char -> PU [Node] Char
forall a. PU Text a -> PU [Node] a
xpContent PU Text Char
forall a. (Show a, Read a) => PU Text a
xpPrim

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

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

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

-- TODO: Do parametric types.

-- | Generic pickling support.
class GXmlPickler t f where
  gxpicklef :: PU t a -> PU t (f a)
  {-# INLINE gxpicklef #-}
  gxpicklef = PU t a -> PU t (f a)
forall a. PU t a -> PU t (f a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
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 :: forall a. PU t a -> PU t (K1 i a a)
gxpickleContentsf PU t a
_ = (a -> K1 i a a) -> (K1 i a a -> a) -> PU t a -> PU t (K1 i a a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 K1 i a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1 PU t a
forall t a. XMLPickler t a => PU t a
xpickle

-- | For empty constructors
instance GXmlPickler [t] U1 where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf :: forall a. PU [t] a -> PU [t] (U1 a)
gxpickleContentsf PU [t] a
_ = (() -> U1 a) -> (U1 a -> ()) -> PU [t] () -> PU [t] (U1 a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (U1 a -> () -> U1 a
forall a b. a -> b -> a
const U1 a
forall k (p :: k). U1 p
U1) (() -> U1 a -> ()
forall a b. a -> b -> a
const ()) PU [t] ()
forall a. PU [a] ()
xpUnit

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

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

-- | For datatypes
instance {-# OVERLAPPABLE #-} (Datatype d, GXmlPickler t f) => GXmlPickler t (M1 D d f) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf :: forall a. PU t a -> PU t (M1 D d f a)
gxpickleContentsf PU t a
f = (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 D d f Any -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (M1 D d f p
forall {p}. M1 D d f p
forall a. HasCallStack => a
undefined :: M1 D d f p), Text
"") (Text, Text) -> PU t (M1 D d f a) -> PU t (M1 D d f a)
forall t a. (Text, Text) -> PU t a -> PU t a
<?+> ((f a -> M1 D d f a)
-> (M1 D d f a -> f a) -> PU t (f a) -> PU t (M1 D d f a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 M1 D d f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (PU t a -> PU t (f a)
forall a. PU t a -> PU t (f a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
gxpicklef PU t a
f))

-- | For constructors
instance {-# OVERLAPPABLE #-} (Constructor c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 C c f) where
  {-# INLINE gxpickleContentsf #-}
  {-# INLINE gxpicklef #-}
  gxpicklef :: forall a. PU [Node] a -> PU [Node] (M1 C c f a)
gxpicklef PU [Node] a
f = Name -> PU [Node] (M1 C c f a) -> PU [Node] (M1 C c f a)
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> ShowS -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
formatElement (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ M1 C c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (M1 C c f p
forall {p}. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p)) (PU [Node] a -> PU [Node] (M1 C c f a)
forall a. PU [Node] a -> PU [Node] (M1 C c f a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
gxpickleContentsf PU [Node] a
f)
  gxpickleContentsf :: forall a. PU [Node] a -> PU [Node] (M1 C c f a)
gxpickleContentsf PU [Node] a
f = ((f a -> M1 C c f a)
-> (M1 C c f a -> f a) -> PU [Node] (f a) -> PU [Node] (M1 C c f a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 M1 C c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (PU [Node] a -> PU [Node] (f a)
forall a. PU [Node] a -> PU [Node] (f a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
gxpicklef PU [Node] a
f))

-- | For record field selectors
instance {-# OVERLAPPABLE #-} (Selector c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 S c f) where
  {-# INLINE gxpickleContentsf #-}
  gxpickleContentsf :: forall a. PU [Node] a -> PU [Node] (M1 S c f a)
gxpickleContentsf PU [Node] a
f = PU [Node] (M1 S c f a) -> M1 S c f Any -> PU [Node] (M1 S c f a)
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p a.
Selector s =>
PU [Node] a -> t i s f p -> PU [Node] a
optElem ((f a -> M1 S c f a)
-> (M1 S c f a -> f a) -> PU [Node] (f a) -> PU [Node] (M1 S c f a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap f a -> M1 S c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 M1 S c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (PU [Node] a -> PU [Node] (f a)
forall a. PU [Node] a -> PU [Node] (f a)
forall t (f :: * -> *) a. GXmlPickler t f => PU t a -> PU t (f a)
gxpicklef PU [Node] a
f)) (M1 S c f p
forall {p}. M1 S c f p
forall a. HasCallStack => a
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 :: forall a. PU [Node] a -> PU [Node] (M1 S c (K1 i (Maybe a)) a)
gxpickleContentsf PU [Node] a
_ = (Maybe a -> M1 S c (K1 i (Maybe a)) a)
-> (M1 S c (K1 i (Maybe a)) a -> Maybe a)
-> PU [Node] (Maybe a)
-> PU [Node] (M1 S c (K1 i (Maybe a)) a)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap (K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a)
-> (Maybe a -> K1 i (Maybe a) a)
-> Maybe a
-> M1 S c (K1 i (Maybe a)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> K1 i (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1) (K1 i (Maybe a) a -> Maybe a
forall k i c (p :: k). K1 i c p -> c
unK1 (K1 i (Maybe a) a -> Maybe a)
-> (M1 S c (K1 i (Maybe a)) a -> K1 i (Maybe a) a)
-> M1 S c (K1 i (Maybe a)) a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 S c (K1 i (Maybe a)) a -> K1 i (Maybe a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (PU [Node] a -> PU [Node] (Maybe a)
forall t a. PU [t] a -> PU [t] (Maybe a)
xpOption (PU [Node] a -> PU [Node] (Maybe a))
-> PU [Node] a -> PU [Node] (Maybe a)
forall a b. (a -> b) -> a -> b
$ PU [Node] a -> M1 S c Any Any -> PU [Node] a
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p a.
Selector s =>
PU [Node] a -> t i s f p -> PU [Node] a
optElem PU [Node] a
forall t a. XMLPickler t a => PU t a
xpickle (M1 S c f p
forall {k} {f :: k -> *} {p :: k}. M1 S c f p
forall a. HasCallStack => a
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 :: forall {k} t (f :: k -> *) (r :: k) (g :: k -> *).
PU t (f r) -> PU t (g r) -> PU t ((:+:) f g r)
xpSum PU t (f r)
l PU t (g r)
r = (Either (f r) (g r) -> (:+:) f g r)
-> ((:+:) f g r -> Either (f r) (g r))
-> PU t (Either (f r) (g r))
-> PU t ((:+:) f g r)
forall a b t. (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap Either (f r) (g r) -> (:+:) f g r
forall {k} {f :: k -> *} {p :: k} {g :: k -> *}.
Either (f p) (g p) -> (:+:) f g p
i (:+:) f g r -> Either (f r) (g r)
forall {k} {f :: k -> *} {g :: k -> *} {p :: k}.
(:+:) f g p -> Either (f p) (g p)
o (PU t (f r) -> PU t (g r) -> PU t (Either (f r) (g r))
forall n t1 t2. PU n t1 -> PU n t2 -> PU n (Either t1 t2)
xpEither PU t (f r)
l PU t (g r)
r)
  where
    i :: Either (f p) (g p) -> (:+:) f g p
i (Left f p
x) = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f p
x
    i (Right g p
x) = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g p
x
    o :: (:+:) f g p -> Either (f p) (g p)
o (L1 f p
x) = f p -> Either (f p) (g p)
forall a b. a -> Either a b
Left f p
x
    o (R1 g p
x) = g p -> Either (f p) (g p)
forall a b. b -> Either a b
Right g p
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 :: forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p a.
Datatype s =>
PU [Node] a -> t i s f p -> PU [Node] a
optElemD PU [Node] a
x t i s f p
y = case ShowS
formatElement (t i s f p -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
datatypeName t i s f p
y) of
  String
"" -> PU [Node] a
x
  String
n -> Name -> PU [Node] a -> PU [Node] a
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes (String -> Name
forall a. IsString a => String -> a
fromString String
n) PU [Node] a
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 :: forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p a.
Constructor s =>
PU [Node] a -> t i s f p -> PU [Node] a
optElemC PU [Node] a
x t i s f p
y = case ShowS
formatElement (t i s f p -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
conName t i s f p
y) of
  String
"" -> PU [Node] a
x
  String
n -> Name -> PU [Node] a -> PU [Node] a
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes (String -> Name
forall a. IsString a => String -> a
fromString String
n) PU [Node] a
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 :: forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p a.
Selector s =>
PU [Node] a -> t i s f p -> PU [Node] a
optElem PU [Node] a
x t i s f p
y = case ShowS
formatElement (t i s f p -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName t i s f p
y) of
  String
"" -> PU [Node] a
x
  String
n -> Name -> PU [Node] a -> PU [Node] a
forall b. Name -> PU [Node] b -> PU [Node] b
xpElemNodes (String -> Name
forall a. IsString a => String -> a
fromString String
n) PU [Node] a
x

-- | Format field names nicely
{-# INLINE formatElement #-}
formatElement :: String -> String
formatElement :: ShowS
formatElement = ShowS
headToLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripLeadingAndTrailingUnderscore

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

{-# INLINE stripLeadingAndTrailingUnderscore #-}
stripLeadingAndTrailingUnderscore :: String -> String
stripLeadingAndTrailingUnderscore :: ShowS
stripLeadingAndTrailingUnderscore = ShowS
stripLeadingUnderscore ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripTrailingUnderscore

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

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