{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
module Html.Reify where
import Html.Type.Internal
import Html.Convert
import Data.Proxy
import GHC.TypeLits
import Data.ByteString.Builder
#if __GLASGOW_HASKELL__ <= 802
import Data.Semigroup ((<>), Semigroup)
#endif
import qualified Data.Sequence as S
type Compactable' a = (ShowTypeList (Variables a), R 'True (T (ToList a) a))
type family Compactable a where Compactable a = Compactable' a
data Put (n :: Symbol) = forall a. Convert a => Put a
type family Retrieve f xs where
Retrieve f (x ': xs) = Put x -> Retrieve f xs
Retrieve f '[] = f
class Retrievable a where
retrieve :: ([Builder] -> [Builder]) -> (Builder -> f) -> CompactHTML a -> Retrieve f a
instance (KnownSymbol x, Retrievable xs) => Retrievable (x ': xs) where
retrieve :: ([Builder] -> [Builder])
-> (Builder -> f) -> CompactHTML (x : xs) -> Retrieve f (x : xs)
retrieve [Builder] -> [Builder]
m Builder -> f
f (MkCompactHTML ByteString
c1 [(Int, ByteString)]
c2) (Put a
x) = ([Builder] -> [Builder])
-> (Builder -> f) -> CompactHTML xs -> Retrieve f xs
forall (a :: [Symbol]) f.
Retrievable a =>
([Builder] -> [Builder])
-> (Builder -> f) -> CompactHTML a -> Retrieve f a
retrieve ([Builder] -> [Builder]
m ([Builder] -> [Builder])
-> ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Converted -> Builder
unConv (a -> Converted
forall a. Convert a => a -> Converted
convert a
x) Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:)) Builder -> f
f (ByteString -> [(Int, ByteString)] -> CompactHTML xs
forall (a :: [Symbol]).
ByteString -> [(Int, ByteString)] -> CompactHTML a
MkCompactHTML @xs ByteString
c1 [(Int, ByteString)]
c2)
instance Retrievable '[] where
retrieve :: ([Builder] -> [Builder])
-> (Builder -> f) -> CompactHTML '[] -> Retrieve f '[]
retrieve [Builder] -> [Builder]
m Builder -> f
f (MkCompactHTML ByteString
bs [(Int, ByteString)]
is) = Builder -> f
f (Builder -> f) -> Builder -> f
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Int, ByteString) -> Builder) -> [(Int, ByteString)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Int
i,ByteString
b) -> [Builder] -> [Builder]
m [] [Builder] -> Int -> Builder
forall a. [a] -> Int -> a
!! Int
i Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
b) [(Int, ByteString)]
is
type Document' a = R 'False (T (ToList a) a)
type family Document a where Document a = Document' a
type family RenderOutput x = r | r -> x where
RenderOutput 'False = Converted
RenderOutput 'True = S.Seq (Either Converted String)
class R u a where
render :: a -> RenderOutput u
instance Convert s
=> R 'False (One s) where
render :: One s -> RenderOutput 'False
render (One s
x) = s -> Converted
forall a. Convert a => a -> Converted
convert s
x
instance Convert s
=> R 'True (One s) where
render :: One s -> RenderOutput 'True
render (One s
x) = Either Converted String -> Seq (Either Converted String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Converted String -> Seq (Either Converted String))
-> (Converted -> Either Converted String)
-> Converted
-> Seq (Either Converted String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Converted -> Either Converted String
forall a b. a -> Either a b
Left (Converted -> Seq (Either Converted String))
-> Converted -> Seq (Either Converted String)
forall a b. (a -> b) -> a -> b
$ s -> Converted
forall a. Convert a => a -> Converted
convert s
x
instance {-# INCOHERENT #-}
KnownSymbol n =>
R 'True (T '[ "" ] (V n)) where
render :: T '[""] (V n) -> RenderOutput 'True
render T '[""] (V n)
_ = Either Converted String -> Seq (Either Converted String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either Converted String
forall a b. b -> Either a b
Right (Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)))
instance {-# INCOHERENT #-}
Monoid (RenderOutput u) => R u (T '[] val) where
render :: T '[] val -> RenderOutput u
render T '[] val
_ = RenderOutput u
forall a. Monoid a => a
mempty
instance {-# INCOHERENT #-}
( R u (One val)
) => R u (T '[ "" ] val) where
render :: T '[""] val -> RenderOutput u
render (T val
x) = One val -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (val -> One val
forall a. a -> One a
One val
x)
instance
( R u (T '[ "" ] b)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
) => R u (T '[s] (a := b)) where
render :: T '[s] (a := b) -> RenderOutput u
render (T (a
_ := b
x)) = One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> T '[""] b -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (b -> T '[""] b
forall k (proxies :: k) target. target -> T proxies target
T b
x :: T '[ "" ] b)
instance {-# INCOHERENT #-}
( R u (T '[ "" ] val)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
) => R u (T '[s] val) where
render :: T '[s] val -> RenderOutput u
render (T val
x) = One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> T '[""] val -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (val -> T '[""] val
forall k (proxies :: k) target. target -> T proxies target
T val
x :: T '[ "" ] val)
instance {-# OVERLAPPING #-}
( R u (One (Proxy s))
, R u (One String)
, Semigroup (RenderOutput u)
) => R u (T '[s] String) where
render :: T '[s] String -> RenderOutput u
render (T String
x) = One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> One String -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (String -> One String
forall a. a -> One a
One String
x)
instance {-# OVERLAPPING #-}
( R u (T xs val)
) => R u (T ('List xs "") val) where
render :: T ('List xs "") val -> RenderOutput u
render (T val
t) = T xs val -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (val -> T xs val
forall k (proxies :: k) target. target -> T proxies target
T val
t :: T xs val)
instance
( R u (T xs val)
, R u (One (Proxy x))
, Semigroup (RenderOutput u)
) => R u (T ('List xs x) val) where
render :: T ('List xs x) val -> RenderOutput u
render (T val
t) = T xs val -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (val -> T xs val
forall k (proxies :: k) target. target -> T proxies target
T val
t :: T xs val) RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> One (Proxy x) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy x -> One (Proxy x)
forall a. a -> One a
One (Proxy x
forall k (t :: k). Proxy t
Proxy @x))
instance
( R u (T (Take (Length a) ps) a)
, R u (T (Drop (Length a) ps) b)
, Semigroup (RenderOutput u)
) => R u (T ps (a # b)) where
render :: T ps (a # b) -> RenderOutput u
render (T ~(a
a :#: b
b))
= T (Take (Length a) ps) a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (a -> T (Take (Length a) ps) a
forall k (proxies :: k) target. target -> T proxies target
T a
a :: T (Take (Length a) ps) a)
RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> T (Drop (Length a) ps) b -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (b -> T (Drop (Length a) ps) b
forall k (proxies :: k) target. target -> T proxies target
T b
b :: T (Drop (Length a) ps) b)
instance
( R u (T (Take (Length a) ps) a)
, R u (T (Drop (Length a) ps) b)
, Semigroup (RenderOutput u)
) => R u (T ps (a :> b)) where
render :: T ps (a :> b) -> RenderOutput u
render (T ~(a
a :> b
b))
= T (Take (Length a) ps) a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (a -> T (Take (Length a) ps) a
forall k (proxies :: k) target. target -> T proxies target
T a
a :: T (Take (Length a) ps) a)
RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> T (Drop (Length a) ps) b -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (b -> T (Drop (Length a) ps) b
forall k (proxies :: k) target. target -> T proxies target
T b
b :: T (Drop (Length a) ps) b)
instance
( R u (T (Drop 0 ps) b)
) => R u (T ps (a :@ b)) where
render :: T ps (a :@ b) -> RenderOutput u
render (T ~(a
_ :@ b
b))
= T ps b -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (b -> T ps b
forall k (proxies :: k) target. target -> T proxies target
T b
b :: T (Drop 0 ps) b)
instance
( R u (T ps a)
) => R u (T ps (Lawless a)) where
render :: T ps (Lawless a) -> RenderOutput u
render (T ~(Lawless a
a))
= T ps a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (a -> T ps a
forall k (proxies :: k) target. target -> T proxies target
T a
a :: T ps a)
instance
( R u (T (ToList a) a)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
, Monoid (RenderOutput u)
) => R u (T (s ': ss) [a]) where
render :: T (s : ss) [a] -> RenderOutput u
render (T [a]
xs)
= One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s))
RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> (a -> RenderOutput u) -> [a] -> RenderOutput u
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (T (ToList a) a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (T (ToList a) a -> RenderOutput u)
-> (a -> T (ToList a) a) -> a -> RenderOutput u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> T (ToList a) a
forall k (proxies :: k) target. target -> T proxies target
T :: a -> T (ToList a) a)) [a]
xs
instance
( R u (T (ToList a) a)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
, Monoid (RenderOutput u)
) => R u (T (s ': ss) (Maybe a)) where
render :: T (s : ss) (Maybe a) -> RenderOutput u
render (T Maybe a
mx)
= One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s))
RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> (a -> RenderOutput u) -> Maybe a -> RenderOutput u
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (T (ToList a) a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (T (ToList a) a -> RenderOutput u)
-> (a -> T (ToList a) a) -> a -> RenderOutput u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> T (ToList a) a
forall k (proxies :: k) target. target -> T proxies target
T :: a -> T (ToList a) a)) Maybe a
mx
instance
( R u (T (ToList a) a)
, R u (T (ToList b) b)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
) => R u (T (s ': ss) (Either a b)) where
render :: T (s : ss) (Either a b) -> RenderOutput u
render (T Either a b
eab)
= One (Proxy s) -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (Proxy s -> One (Proxy s)
forall a. a -> One a
One (Proxy s
forall k (t :: k). Proxy t
Proxy @s))
RenderOutput u -> RenderOutput u -> RenderOutput u
forall a. Semigroup a => a -> a -> a
<> (a -> RenderOutput u)
-> (b -> RenderOutput u) -> Either a b -> RenderOutput u
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (T (ToList a) a -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (T (ToList a) a -> RenderOutput u)
-> (a -> T (ToList a) a) -> a -> RenderOutput u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> T (ToList a) a
forall k (proxies :: k) target. target -> T proxies target
T :: a -> T (ToList a) a)) (T (ToList b) b -> RenderOutput u
forall (u :: Bool) a. R u a => a -> RenderOutput u
render (T (ToList b) b -> RenderOutput u)
-> (b -> T (ToList b) b) -> b -> RenderOutput u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> T (ToList b) b
forall k (proxies :: k) target. target -> T proxies target
T :: b -> T (ToList b) b)) Either a b
eab