{-# LANGUAGE AllowAmbiguousTypes      #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DerivingStrategies       #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE FunctionalDependencies   #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PolyKinds                #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE StandaloneDeriving       #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications         #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE UndecidableInstances     #-}
module Composite.XML (RecXML(RNode)
         , ToAttr(..)
         , ToAttrs(..)
         , FromAttr(..)
         , FromAttrs(..)
         , Formattable(..)
         , Readable(..)
         , ToElement(..)
         , ToElements(..)
         , FromElement(..)
         , FromElements(..)) where



import           Composite.CoRecord
import           Composite.Record
import           Control.Arrow
import           Control.Monad
import           Data.Functor.Identity
import           Data.Kind
import           Data.Map              (Map)
import qualified Data.Map              as Map
import           Data.Maybe
import           Data.Proxy
import           Data.Ratio
import           Data.String
import           Data.Text             (Text)
import qualified Data.Text             as T
import           Data.Vinyl
import           Data.Vinyl.Functor    hiding (Identity)
import           GHC.TypeLits
import           Text.XML              as X

type RecXML :: Symbol -> [Type] -> [Type] -> Type
data RecXML :: Symbol -> [Type] -> [Type] -> Type where
  RNode :: Rec Maybe xs -> [Field ys] -> RecXML s xs ys

deriving stock instance (Show (Field ys), Show (Rec Maybe xs), RecApplicative ys) => Show (RecXML s xs ys)
deriving stock instance (Eq (Field ys), Eq (Rec Maybe xs), RecApplicative ys) => Eq (RecXML s xs ys)

type ToAttrs :: Type -> Constraint
class ToAttrs x where
  toAttrs :: x -> Map Name Text

instance ToAttrs (Rec f '[]) where
  toAttrs :: Rec f '[] -> Map Name Text
toAttrs Rec f '[]
RNil = Map Name Text
forall a. Monoid a => a
mempty

type Formattable :: Type -> Constraint
class Formattable x where
  formatC :: x -> Text

instance Formattable Bool where
  formatC :: Bool -> Text
formatC Bool
True  = Text
"true"
  formatC Bool
False = Text
"false"

instance Formattable String where
  formatC :: String -> Text
formatC = String -> Text
T.pack

instance Formattable Int where
  formatC :: Int -> Text
formatC = String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

instance Formattable () where
  formatC :: () -> Text
formatC = String -> Text
T.pack (String -> Text) -> (() -> String) -> () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> String
forall a. Show a => a -> String
show

instance Formattable (Ratio Integer) where
  formatC :: Ratio Integer -> Text
formatC = String -> Text
T.pack (String -> Text)
-> (Ratio Integer -> String) -> Ratio Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> String
forall a. Show a => a -> String
show

instance Formattable Double where
  formatC :: Double -> Text
formatC = String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show

instance Formattable Text where
  formatC :: Text -> Text
formatC = Text -> Text
forall a. a -> a
id

type ToAttr :: Type -> Constraint
class ToAttr a where
  toAttr :: a -> (Name, Text)

instance (Formattable a, KnownSymbol s) => ToAttr (s :-> a) where
  toAttr :: (s :-> a) -> (Name, Text)
toAttr = (Text -> Name) -> (Text, Text) -> (Name, Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ((Text, Text) -> (Name, Text))
-> ((s :-> a) -> (Text, Text)) -> (s :-> a) -> (Name, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> (Text, a) -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Text
forall x. Formattable x => x -> Text
formatC ((Text, a) -> (Text, Text))
-> ((s :-> a) -> (Text, a)) -> (s :-> a) -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s :-> a) -> (Text, a)
forall (s :: Symbol) a. KnownSymbol s => (s :-> a) -> (Text, a)
valWithName

instance (ToAttr x, ToAttrs (Record xs)) => ToAttrs (Record (x ': xs)) where
  toAttrs :: Record (x : xs) -> Map Name Text
toAttrs (Identity r
x :& Rec Identity rs
xs) = ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Text)] -> Map Name Text)
-> (r -> [(Name, Text)]) -> r -> Map Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Text) -> [(Name, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Text) -> [(Name, Text)])
-> (r -> (Name, Text)) -> r -> [(Name, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> (Name, Text)
forall a. ToAttr a => a -> (Name, Text)
toAttr (r -> Map Name Text) -> r -> Map Name Text
forall a b. (a -> b) -> a -> b
$ r
x) Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Rec Identity rs -> Map Name Text
forall x. ToAttrs x => x -> Map Name Text
toAttrs Rec Identity rs
xs

instance (ToAttr x, ToAttrs (Rec Maybe xs)) => ToAttrs (Rec Maybe (x ': xs)) where
  toAttrs :: Rec Maybe (x : xs) -> Map Name Text
toAttrs (Just r
x :& Rec Maybe rs
xs)  = ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Text)] -> Map Name Text)
-> (r -> [(Name, Text)]) -> r -> Map Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Text) -> [(Name, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Text) -> [(Name, Text)])
-> (r -> (Name, Text)) -> r -> [(Name, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> (Name, Text)
forall a. ToAttr a => a -> (Name, Text)
toAttr (r -> Map Name Text) -> r -> Map Name Text
forall a b. (a -> b) -> a -> b
$ r
x) Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Rec Maybe rs -> Map Name Text
forall x. ToAttrs x => x -> Map Name Text
toAttrs Rec Maybe rs
xs
  toAttrs (Maybe r
Nothing :& Rec Maybe rs
xs) = Rec Maybe rs -> Map Name Text
forall x. ToAttrs x => x -> Map Name Text
toAttrs Rec Maybe rs
xs


type ToElement :: Type -> Constraint
class ToElement a where
  toElement :: a -> Element

type ToElements :: Type -> Constraint
class ToElements x where
  toElements :: x -> [Element]

instance ToElements (Rec f '[]) where
  toElements :: Rec f '[] -> [Element]
toElements Rec f '[]
RNil = [Element]
forall a. Monoid a => a
mempty

instance (ToElement x, ToElements (Record xs)) => ToElements (Record (x ': xs)) where
  toElements :: Record (x : xs) -> [Element]
toElements (Identity r
x :& Rec Identity rs
xs) = r -> Element
forall a. ToElement a => a -> Element
toElement r
x Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Rec Identity rs -> [Element]
forall x. ToElements x => x -> [Element]
toElements Rec Identity rs
xs

instance (KnownSymbol s, ToAttrs (Rec Maybe xs), RecApplicative ys, AllHave '[ToElement] ys) => ToElement (RecXML s xs ys) where
  toElement :: RecXML s xs ys -> Element
toElement (RNode Rec Maybe xs
x [Field ys]
y) = Name -> Map Name Text -> [Node] -> Element
Element (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @s (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)) (Rec Maybe xs -> Map Name Text
forall x. ToAttrs x => x -> Map Name Text
toAttrs Rec Maybe xs
x) (Element -> Node
NodeElement (Element -> Node) -> [Element] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field ys] -> [Element]
forall x. ToElements x => x -> [Element]
toElements [Field ys]
y)

type Readable :: Type -> Constraint
class Readable x where
  readC :: Text -> Maybe x

instance Readable Bool where
  readC :: Text -> Maybe Bool
readC = \case
    Text
"true"  -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    Text
_       -> Maybe Bool
forall a. Maybe a
Nothing

instance Readable String where
  readC :: Text -> Maybe String
readC = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Text -> String) -> Text -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance Readable Text where
  readC :: Text -> Maybe Text
readC = Text -> Maybe Text
forall a. a -> Maybe a
Just

instance Readable Double where
  readC :: Text -> Maybe Double
readC = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double)
-> (Text -> Double) -> Text -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
forall a. Read a => String -> a
read (String -> Double) -> (Text -> String) -> Text -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance Readable Int where
  readC :: Text -> Maybe Int
readC = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Text -> Int) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (Text -> String) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

type FromAttr :: Symbol -> Type -> Constraint
class FromAttr s a | a -> s where
  fromAttr :: (Name, Text) -> Maybe a

instance (Readable a, KnownSymbol s) => FromAttr s (s :-> a) where
  fromAttr :: (Name, Text) -> Maybe (s :-> a)
fromAttr (Name
n, Text
x) = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
forall a. IsString a => String -> a
fromString (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @s (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)) then forall a. a -> s :-> a
forall (s :: Symbol) a. a -> s :-> a
Val @s (a -> s :-> a) -> Maybe a -> Maybe (s :-> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe a
forall x. Readable x => Text -> Maybe x
readC Text
x else Maybe (s :-> a)
forall a. Maybe a
Nothing

type FromAttrs :: Type -> Constraint
class FromAttrs a where
  fromAttrs :: [(Name, Text)] -> Maybe a

instance FromAttrs (Rec f '[]) where
  fromAttrs :: [(Name, Text)] -> Maybe (Rec f '[])
fromAttrs [(Name, Text)]
_ = Rec f '[] -> Maybe (Rec f '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rec f '[]
forall u (a :: u -> *). Rec a '[]
RNil

instance (FromAttr s (s :-> x), FromAttrs (Record xs)) => FromAttrs (Record (s :-> x ': xs)) where
  fromAttrs :: [(Name, Text)] -> Maybe (Record ((s :-> x) : xs))
fromAttrs [(Name, Text)]
xs = do
    let as' :: [((Name, Text), Maybe (s :-> x))]
as' = ((Name, Text) -> ((Name, Text), Maybe (s :-> x)))
-> [(Name, Text)] -> [((Name, Text), Maybe (s :-> x))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name, Text)
i -> ((Name, Text)
i, (Name, Text) -> Maybe (s :-> x)
forall (s :: Symbol) a. FromAttr s a => (Name, Text) -> Maybe a
fromAttr @s @(s :-> x) (Name, Text)
i)) [(Name, Text)]
xs
    let ts :: [Maybe (s :-> x)]
ts = ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> [((Name, Text), Maybe (s :-> x))] -> [Maybe (s :-> x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Text), Maybe (s :-> x)) -> Bool)
-> [((Name, Text), Maybe (s :-> x))]
-> [((Name, Text), Maybe (s :-> x))]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Maybe (s :-> x) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (s :-> x) -> Bool)
-> (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> ((Name, Text), Maybe (s :-> x))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd) [((Name, Text), Maybe (s :-> x))]
as'
    let rs :: [(Name, Text)]
rs = ((Name, Text), Maybe (s :-> x)) -> (Name, Text)
forall a b. (a, b) -> a
fst (((Name, Text), Maybe (s :-> x)) -> (Name, Text))
-> [((Name, Text), Maybe (s :-> x))] -> [(Name, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Text), Maybe (s :-> x)) -> Bool)
-> [((Name, Text), Maybe (s :-> x))]
-> [((Name, Text), Maybe (s :-> x))]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Maybe (s :-> x) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (s :-> x) -> Bool)
-> (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> ((Name, Text), Maybe (s :-> x))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd) [((Name, Text), Maybe (s :-> x))]
as'
    s :-> x
t <- Maybe (Maybe (s :-> x)) -> Maybe (s :-> x)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (s :-> x)) -> Maybe (s :-> x))
-> Maybe (Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a -> b) -> a -> b
$ [Maybe (s :-> x)] -> Maybe (Maybe (s :-> x))
forall a. [a] -> Maybe a
listToMaybe [Maybe (s :-> x)]
ts
    Record xs
xs' <- [(Name, Text)] -> Maybe (Record xs)
forall a. FromAttrs a => [(Name, Text)] -> Maybe a
fromAttrs [(Name, Text)]
rs
    Record ((s :-> x) : xs) -> Maybe (Record ((s :-> x) : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Record ((s :-> x) : xs) -> Maybe (Record ((s :-> x) : xs)))
-> Record ((s :-> x) : xs) -> Maybe (Record ((s :-> x) : xs))
forall a b. (a -> b) -> a -> b
$ (s :-> x) -> Identity (s :-> x)
forall a. a -> Identity a
Identity s :-> x
t Identity (s :-> x) -> Record xs -> Record ((s :-> x) : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Record xs
xs'

instance (FromAttr s (s :-> x), FromAttrs (Rec Maybe xs)) => FromAttrs (Rec Maybe (s :-> x ': xs)) where
  fromAttrs :: [(Name, Text)] -> Maybe (Rec Maybe ((s :-> x) : xs))
fromAttrs [(Name, Text)]
xs = do
    let as' :: [((Name, Text), Maybe (s :-> x))]
as' = ((Name, Text) -> ((Name, Text), Maybe (s :-> x)))
-> [(Name, Text)] -> [((Name, Text), Maybe (s :-> x))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name, Text)
i -> ((Name, Text)
i, (Name, Text) -> Maybe (s :-> x)
forall (s :: Symbol) a. FromAttr s a => (Name, Text) -> Maybe a
fromAttr @s @(s :-> x) (Name, Text)
i)) [(Name, Text)]
xs
    let ts :: [Maybe (s :-> x)]
ts = ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> [((Name, Text), Maybe (s :-> x))] -> [Maybe (s :-> x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Text), Maybe (s :-> x)) -> Bool)
-> [((Name, Text), Maybe (s :-> x))]
-> [((Name, Text), Maybe (s :-> x))]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Maybe (s :-> x) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (s :-> x) -> Bool)
-> (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> ((Name, Text), Maybe (s :-> x))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd) [((Name, Text), Maybe (s :-> x))]
as'
    let rs :: [(Name, Text)]
rs = ((Name, Text), Maybe (s :-> x)) -> (Name, Text)
forall a b. (a, b) -> a
fst (((Name, Text), Maybe (s :-> x)) -> (Name, Text))
-> [((Name, Text), Maybe (s :-> x))] -> [(Name, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Text), Maybe (s :-> x)) -> Bool)
-> [((Name, Text), Maybe (s :-> x))]
-> [((Name, Text), Maybe (s :-> x))]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Maybe (s :-> x) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (s :-> x) -> Bool)
-> (((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x))
-> ((Name, Text), Maybe (s :-> x))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Text), Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a, b) -> b
snd) [((Name, Text), Maybe (s :-> x))]
as'
    let t :: Maybe (s :-> x)
t = Maybe (Maybe (s :-> x)) -> Maybe (s :-> x)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (s :-> x)) -> Maybe (s :-> x))
-> Maybe (Maybe (s :-> x)) -> Maybe (s :-> x)
forall a b. (a -> b) -> a -> b
$ [Maybe (s :-> x)] -> Maybe (Maybe (s :-> x))
forall a. [a] -> Maybe a
listToMaybe [Maybe (s :-> x)]
ts
    Rec Maybe xs
xs' <- [(Name, Text)] -> Maybe (Rec Maybe xs)
forall a. FromAttrs a => [(Name, Text)] -> Maybe a
fromAttrs [(Name, Text)]
rs
    Rec Maybe ((s :-> x) : xs) -> Maybe (Rec Maybe ((s :-> x) : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rec Maybe ((s :-> x) : xs) -> Maybe (Rec Maybe ((s :-> x) : xs)))
-> Rec Maybe ((s :-> x) : xs) -> Maybe (Rec Maybe ((s :-> x) : xs))
forall a b. (a -> b) -> a -> b
$ Maybe (s :-> x)
t Maybe (s :-> x) -> Rec Maybe xs -> Rec Maybe ((s :-> x) : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Maybe xs
xs'

type FromElement :: Type -> Constraint
class FromElement a where
  fromElement :: Element -> Maybe a

type FromElements :: Type -> Constraint
class FromElements x where
  fromElements :: [Element] -> Maybe x

instance forall ys. (AllHave '[ToElement] ys, RecApplicative ys) => ToElement (CoRec Identity ys) where
  toElement :: CoRec Identity ys -> Element
toElement (CoVal (Identity r
x)) = r -> Element
toElement' r
x
    where
      toElementer :: Rec (Op Element) ys
      toElementer :: Rec (Op Element) ys
toElementer = Proxy '[ToElement]
-> (forall (proxy' :: * -> *) a.
    HasInstances a '[ToElement] =>
    proxy' a -> Op Element a)
-> Rec (Op Element) ys
forall u (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u])
       (proxy :: [u -> Constraint] -> *).
(AllHave cs rs, RecApplicative rs) =>
proxy cs
-> (forall (proxy' :: u -> *) (a :: u).
    HasInstances a cs =>
    proxy' a -> f a)
-> Rec f rs
reifyDicts (Proxy '[ToElement]
forall k (t :: k). Proxy t
Proxy @'[ToElement]) (\proxy' a
_ -> (a -> Element) -> Op Element a
forall b a. (a -> b) -> Op b a
Op a -> Element
forall a. ToElement a => a -> Element
toElement)
      toElement' :: r -> Element
toElement' = Op Element r -> r -> Element
forall b a. Op b a -> a -> b
runOp (Rec (Op Element) ys -> Op Element r
forall k (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget Rec (Op Element) ys
toElementer)

instance forall ys. (AllHave '[FromElement] ys, RecApplicative ys, FoldRec ys ys, RMap ys) => FromElement (CoRec Identity ys) where
  fromElement :: Element -> Maybe (CoRec Identity ys)
fromElement Element
x = Rec Maybe ys -> Maybe (CoRec Identity ys)
forall (rs :: [*]).
(FoldRec rs rs, RMap rs) =>
Rec Maybe rs -> Maybe (Field rs)
firstField (Rec Maybe ys -> Maybe (CoRec Identity ys))
-> Rec Maybe ys -> Maybe (CoRec Identity ys)
forall a b. (a -> b) -> a -> b
$ ((Element -> Rec Maybe ys) -> Element -> Rec Maybe ys
forall a b. (a -> b) -> a -> b
$ Element
x) ((Element -> Rec Maybe ys) -> Rec Maybe ys)
-> (Element -> Rec Maybe ys) -> Rec Maybe ys
forall a b. (a -> b) -> a -> b
$ (forall x. (:.) ((->) Element) Maybe x -> Element -> Maybe x)
-> Rec ((->) Element :. Maybe) ys -> Element -> Rec Maybe ys
forall u (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse forall x. (:.) ((->) Element) Maybe x -> Element -> Maybe x
forall l (f :: l -> *) k (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose Rec ((->) Element :. Maybe) ys
fromElementer where
    fromElementer :: Rec ((->) Element :. Maybe ) ys
    fromElementer :: Rec ((->) Element :. Maybe) ys
fromElementer = Proxy '[FromElement]
-> (forall (proxy' :: * -> *) a.
    HasInstances a '[FromElement] =>
    proxy' a -> (:.) ((->) Element) Maybe a)
-> Rec ((->) Element :. Maybe) ys
forall u (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u])
       (proxy :: [u -> Constraint] -> *).
(AllHave cs rs, RecApplicative rs) =>
proxy cs
-> (forall (proxy' :: u -> *) (a :: u).
    HasInstances a cs =>
    proxy' a -> f a)
-> Rec f rs
reifyDicts (Proxy '[FromElement]
forall k (t :: k). Proxy t
Proxy @'[FromElement]) (\proxy' a
_ -> (Element -> Maybe a) -> (:.) ((->) Element) Maybe a
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose Element -> Maybe a
forall a. FromElement a => Element -> Maybe a
fromElement)

instance ToElement a => ToElements [a] where
  toElements :: [a] -> [Element]
toElements = (a -> Element) -> [a] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map a -> Element
forall a. ToElement a => a -> Element
toElement

instance FromElement a => FromElements [a] where
  fromElements :: [Element] -> Maybe [a]
fromElements = (Element -> Maybe a) -> [Element] -> Maybe [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse Element -> Maybe a
forall a. FromElement a => Element -> Maybe a
fromElement

instance FromElements (Record '[]) where
  fromElements :: [Element] -> Maybe (Record '[])
fromElements [] = Record '[] -> Maybe (Record '[])
forall a. a -> Maybe a
Just Record '[]
forall u (a :: u -> *). Rec a '[]
RNil
  fromElements [Element]
_  = Maybe (Record '[])
forall a. Maybe a
Nothing

instance (FromElement x, FromElements (Record xs)) => FromElements (Record (x ': xs)) where
  fromElements :: [Element] -> Maybe (Record (x : xs))
fromElements (Element
x : [Element]
xs) = do
     x
x' <- Element -> Maybe x
forall a. FromElement a => Element -> Maybe a
fromElement Element
x
     Record xs
xs' <- [Element] -> Maybe (Record xs)
forall x. FromElements x => [Element] -> Maybe x
fromElements [Element]
xs
     Record (x : xs) -> Maybe (Record (x : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Record (x : xs) -> Maybe (Record (x : xs)))
-> Record (x : xs) -> Maybe (Record (x : xs))
forall a b. (a -> b) -> a -> b
$ x -> Identity x
forall a. a -> Identity a
Identity x
x' Identity x -> Record xs -> Record (x : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Record xs
xs'
  fromElements [Element]
_ = Maybe (Record (x : xs))
forall a. Maybe a
Nothing

instance (KnownSymbol s, FromAttrs (Rec Maybe xs), FromElement (CoRec Identity ys)) => FromElement (RecXML s xs ys) where
  fromElement :: Element -> Maybe (RecXML s xs ys)
fromElement (Element Name
n Map Name Text
xs [Node]
ys) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> String
T.unpack (Name -> Text
nameLocalName Name
n))
    Rec Maybe xs
xs' <- [(Name, Text)] -> Maybe (Rec Maybe xs)
forall a. FromAttrs a => [(Name, Text)] -> Maybe a
fromAttrs ([(Name, Text)] -> Maybe (Rec Maybe xs))
-> [(Name, Text)] -> Maybe (Rec Maybe xs)
forall a b. (a -> b) -> a -> b
$ Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name Text
xs
    [Element]
ts <- [Maybe Element] -> Maybe [Element]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe Element] -> Maybe [Element])
-> [Maybe Element] -> Maybe [Element]
forall a b. (a -> b) -> a -> b
$ (Maybe Element -> Bool) -> [Maybe Element] -> [Maybe Element]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter Maybe Element -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe Element] -> [Maybe Element])
-> [Maybe Element] -> [Maybe Element]
forall a b. (a -> b) -> a -> b
$ (Node -> Maybe Element) -> [Node] -> [Maybe Element]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map
                    (\case
                       NodeElement Element
x' -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
x'
                       Node
_              -> Maybe Element
forall a. Maybe a
Nothing) [Node]
ys
    [CoRec Identity ys]
ys' <- [Element] -> Maybe [CoRec Identity ys]
forall x. FromElements x => [Element] -> Maybe x
fromElements [Element]
ts
    RecXML s xs ys -> Maybe (RecXML s xs ys)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecXML s xs ys -> Maybe (RecXML s xs ys))
-> RecXML s xs ys -> Maybe (RecXML s xs ys)
forall a b. (a -> b) -> a -> b
$ Rec Maybe xs -> [CoRec Identity ys] -> RecXML s xs ys
forall (xs :: [*]) (ys :: [*]) (s :: Symbol).
Rec Maybe xs -> [Field ys] -> RecXML s xs ys
RNode Rec Maybe xs
xs' [CoRec Identity ys]
ys'