{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.XML.Twiml.Internal
(
(:+:)(..)
, (:<:)(..)
, Elem
, type (∉)
, Functor1(..)
, NFData1(..)
, Show1(..)
, IxApplicative(..)
, IxMonad(..)
, IxFree(..)
, iliftF
, type (++)
, SomeNode(..)
, ToSomeNode(..)
, ToXML(..)
, ToElement(..)
, ToAttrs(..)
, ToAttrValue(..)
, makeAttr
, makeAttr'
, makeAttrs
, makeElement
) where
import Control.DeepSeq (NFData(..))
import Data.Data
import Data.Maybe (mapMaybe)
import GHC.Generics (Generic)
import Text.XML.Light
data (f :+: g) a = InL (f a) | InR (g a)
deriving (Eq, Functor, Generic, NFData, Ord, Read, Show)
infixr 7 :+:
deriving instance (Data a, Data (f a), Data (g a), Typeable f, Typeable g) => Data ((f :+: g) a)
class (Functor sub, Functor sup) => sub :<: sup where
inj :: sub a -> sup a
prj :: sup a -> Maybe (sub a)
instance Functor f => f :<: f where
inj = id
prj = Just
instance {-# OVERLAPPABLE #-} (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where
inj = InR . inj
prj (InR g) = prj g
prj _ = Nothing
instance {-# OVERLAPPING #-} (Functor f, Functor g) => f :<: (f :+: g) where
inj = InL
prj (InL f) = Just f
prj _ = Nothing
type family Elem (t :: k) (ts :: [k]) :: Bool where
Elem t '[] = 'False
Elem t (t ': ts) = 'True
Elem t (u ': ts) = Elem t ts
type t ∉ ts = Elem t ts ~ 'False
class Functor1 f where
fmap1 :: (a -> b) -> f i a -> f i b
class Show1 f where
show1 :: Show a => f i a -> String
class Functor1 f => IxApplicative (f :: k -> * -> *) where
type Identity :: k
type (i :: k) <> (j :: k) :: k
ipure :: a -> f Identity a
iap :: f i (a -> b) -> f j a -> f (i <> j) b
class IxApplicative m => IxMonad (m :: k -> * -> *) where
ibind :: m i a -> (a -> m j b) -> m (i <> j) b
data IxFree f (i :: [k]) a where
IxPure :: a -> IxFree f '[] a
IxFree :: WitnessList i => f i (IxFree f j a) -> IxFree f (i ++ j) a
instance (Show1 f, Show a) => Show (IxFree f i a) where
show (IxPure a) = "IxPure (" ++ show a ++ ")"
show (IxFree fa) = "IxFree (" ++ show1 fa ++ ")"
instance Show1 f => Show1 (IxFree f) where
show1 = show
instance Functor1 f => Functor (IxFree f i) where
fmap = fmap1
instance Functor1 f => Functor1 (IxFree f) where
fmap1 = fmap
instance Functor1 f => IxApplicative (IxFree f) where
type Identity = '[]
type i <> j = i ++ j
ipure = IxPure
iap = iap'
iap'
:: forall f i j a b. Functor1 f
=> IxFree f i (a -> b) -> IxFree f j a -> IxFree f (i ++ j) b
iap' (IxPure f) (IxPure a) = IxPure $ f a
iap' (IxPure f) (IxFree mb) = IxFree $ fmap1 (fmap f) mb
iap' (IxFree (mf :: f i1 (IxFree f j1 (a -> b)))) a =
case associativity (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j)
of Refl -> IxFree $ fmap1 (`iap'` a) mf
instance (Functor1 m, IxApplicative (IxFree m)) => IxMonad (IxFree m) where
ibind = ibind'
ibind'
:: forall f i j a b. Functor1 f
=> IxFree f i a -> (a -> IxFree f j b) -> IxFree f (i ++ j) b
ibind' (IxPure a) f = f a
ibind' (IxFree (x :: f i1 (IxFree f j1 a))) f =
case associativity (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j)
of Refl -> IxFree $ fmap1 (`ibind'` f) x
iliftF :: forall f i a . (WitnessList i, Functor1 f) => f i a -> IxFree f i a
iliftF = case rightIdentity (witness :: SList i) of Refl -> IxFree . fmap1 IxPure
class NFData1 f where
rnf1 :: NFData a => f i a -> ()
instance NFData1 f => NFData1 (IxFree f) where
rnf1 = rnf
instance (NFData1 f, NFData a) => NFData (IxFree f i a) where
rnf (IxPure a) = rnf a
rnf (IxFree fa) = rnf1 fa
type family (++) (a :: [k]) (b :: [k]) :: [k] where
'[] ++ bs = bs
(a ': as) ++ bs = a ': as ++ bs
data SList (i :: [k]) where
Nil :: SList '[]
Succ :: SList t -> SList (h ': t)
class WitnessList (xs :: [k]) where
witness :: SList xs
instance WitnessList '[] where
witness = Nil
instance WitnessList xs => WitnessList (x ': xs) where
witness = Succ witness
associativity :: SList xs -> Proxy ys -> Proxy zs
-> (xs ++ (ys ++ zs)) :~: ((xs ++ ys) ++ zs)
associativity Nil _ _ = Refl
associativity (Succ xs) ys zs =
case associativity xs ys zs of Refl -> Refl
rightIdentity :: SList xs -> xs :~: (xs ++ '[])
rightIdentity Nil = Refl
rightIdentity (Succ xs) = case rightIdentity xs of Refl -> Refl
data SomeNode = forall n. Node n => SomeNode n
class ToSomeNode a where
toSomeNode :: a -> SomeNode
instance ToSomeNode a => ToSomeNode (Maybe a) where
toSomeNode (Just a) = toSomeNode a
toSomeNode _ = SomeNode ()
instance Node SomeNode where
node qName (SomeNode n) = node qName n
instance ToSomeNode String where
toSomeNode str = SomeNode . Text $ CData CDataText str Nothing
instance {-# OVERLAPPING #-} ToSomeNode () where
toSomeNode = SomeNode
instance {-# OVERLAPPABLE #-} ToSomeNode n => Node n where
node qName n = node qName (toSomeNode n)
class ToXML a where
toXML :: a -> [Element]
instance (ToXML (f a), ToXML (g a)) => ToXML ((f :+: g) a) where
toXML (InL f) = toXML f
toXML (InR g) = toXML g
class ToElement a where
toElement :: a -> Element
class ToAttrs a where
toAttrs :: a -> [Attr]
class ToAttrValue a where
toAttrValue :: a -> String
instance ToAttrValue Bool where
toAttrValue True = "true"
toAttrValue False = "false"
instance ToAttrValue String where
toAttrValue = id
makeAttr :: ToAttrValue b => String -> (a -> Maybe b) -> a -> Maybe Attr
makeAttr str f a = Attr (unqual str) . toAttrValue <$> f a
makeAttr' :: String -> (a -> Maybe b) -> (b -> String) -> a -> Maybe Attr
makeAttr' str f g a = Attr (unqual str) . g <$> f a
makeAttrs :: a -> [a -> Maybe Attr] -> [Attr]
makeAttrs a = mapMaybe ($ a)
makeElement :: Node t => String -> t -> [Attr] -> Element
makeElement str c attrs = add_attrs attrs $ unode str c