XML.hs

{-# 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 RNil = mempty

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

instance Formattable Bool where
  formatC True  = "true"
  formatC False = "false"

instance Formattable String where
  formatC = T.pack

instance Formattable Int where
  formatC = T.pack . show

instance Formattable () where
  formatC = T.pack . show

instance Formattable (Ratio Integer) where
  formatC = T.pack . show

instance Formattable Double where
  formatC = T.pack . show

instance Formattable Text where
  formatC = id

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

instance (Formattable a, KnownSymbol s) => ToAttr (s :-> a) where
  toAttr = first (fromString . T.unpack) . fmap formatC . valWithName

instance (ToAttr x, ToAttrs (Record xs)) => ToAttrs (Record (x ': xs)) where
  toAttrs (Identity x :& xs) = (Map.fromList . pure . toAttr $ x) <> toAttrs xs

instance (ToAttr x, ToAttrs (Rec Maybe xs)) => ToAttrs (Rec Maybe (x ': xs)) where
  toAttrs (Just x :& xs)  = (Map.fromList . pure . toAttr $ x) <> toAttrs xs
  toAttrs (Nothing :& xs) = toAttrs 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 RNil = mempty

instance (ToElement x, ToElements (Record xs)) => ToElements (Record (x ': xs)) where
  toElements (Identity x :& xs) = toElement x : toElements xs

instance (KnownSymbol s, ToAttrs (Rec Maybe xs), RecApplicative ys, AllHave '[ToElement] ys) => ToElement (RecXML s xs ys) where
  toElement (RNode x y) = Element (fromString $ symbolVal @s (Proxy :: Proxy s)) (toAttrs x) (NodeElement <$> toElements y)

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

instance Readable Bool where
  readC = \case
    "true"  -> Just True
    "false" -> Just False
    _       -> Nothing

instance Readable String where
  readC = Just . T.unpack

instance Readable Text where
  readC = Just

instance Readable Double where
  readC = Just . read . T.unpack

instance Readable Int where
  readC = Just . read . 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 (n, x) = if n == fromString (symbolVal @s (Proxy :: Proxy s)) then Val @s <$> readC x else Nothing

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

instance FromAttrs (Rec f '[]) where
  fromAttrs _ = pure RNil

instance (FromAttr s (s :-> x), FromAttrs (Record xs)) => FromAttrs (Record (s :-> x ': xs)) where
  fromAttrs xs = do
    let as' = fmap (\i -> (i, fromAttr @s @(s :-> x) i)) xs
    let ts = snd <$> Prelude.filter (isJust . snd) as'
    let rs = fst <$> Prelude.filter (isNothing . snd) as'
    t <- join $ listToMaybe ts
    xs' <- fromAttrs rs
    pure $ Identity t :& xs'

instance (FromAttr s (s :-> x), FromAttrs (Rec Maybe xs)) => FromAttrs (Rec Maybe (s :-> x ': xs)) where
  fromAttrs xs = do
    let as' = fmap (\i -> (i, fromAttr @s @(s :-> x) i)) xs
    let ts = snd <$> Prelude.filter (isJust . snd) as'
    let rs = fst <$> Prelude.filter (isNothing . snd) as'
    let t = join $ listToMaybe ts
    xs' <- fromAttrs rs
    pure $ t :& 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 (CoVal (Identity x)) = toElement' x
    where
      toElementer :: Rec (Op Element) ys
      toElementer = reifyDicts (Proxy @'[ToElement]) (\_ -> Op toElement)
      toElement' = runOp (rget toElementer)

instance forall ys. (AllHave '[FromElement] ys, RecApplicative ys, FoldRec ys ys, RMap ys) => FromElement (CoRec Identity ys) where
  fromElement x = firstField $ ($ x) $ rtraverse getCompose fromElementer where
    fromElementer :: Rec ((->) Element :. Maybe ) ys
    fromElementer = reifyDicts (Proxy @'[FromElement]) (\_ -> Compose fromElement)

instance ToElement a => ToElements [a] where
  toElements = Prelude.map toElement

instance FromElement a => FromElements [a] where
  fromElements = Prelude.traverse fromElement

instance FromElements (Record '[]) where
  fromElements [] = Just RNil
  fromElements _  = Nothing

instance (FromElement x, FromElements (Record xs)) => FromElements (Record (x ': xs)) where
  fromElements (x : xs) = do
     x' <- fromElement x
     xs' <- fromElements xs
     pure $ Identity x' :& xs'
  fromElements _ = Nothing

instance (KnownSymbol s, FromAttrs (Rec Maybe xs), FromElement (CoRec Identity ys)) => FromElement (RecXML s xs ys) where
  fromElement (Element n xs ys) = do
    guard (symbolVal (Proxy @s) == T.unpack (nameLocalName n))
    xs' <- fromAttrs $ Map.toList xs
    ts <- sequence $ Prelude.filter isJust $ Prelude.map
                    (\case
                       NodeElement x' -> Just x'
                       _              -> Nothing) ys
    ys' <- fromElements ts
    pure $ RNode xs' ys'