{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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 (Reverse (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 -> f) -> CompactHTML a -> Retrieve f a
instance (KnownSymbol x, Retrievable xs) => Retrievable (x ': xs) where
retrieve m f (MkCompactHTML c1 c2) (Put x) = retrieve (unConv (convert x) : m) f (MkCompactHTML @ xs c1 c2)
instance Retrievable '[] where
retrieve m f (MkCompactHTML bs is) = f $ byteString bs <> foldMap (\(i,b) -> m !! i <> byteString b) 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 x) = convert x
instance Convert s
=> R 'True (One s) where
render (One x) = pure . Left $ convert x
instance {-# INCOHERENT #-}
KnownSymbol n =>
R 'True (T '[ "" ] (V n)) where
render _ = pure (Right (symbolVal (Proxy @ n)))
instance {-# INCOHERENT #-}
Monoid (RenderOutput u) => R u (T '[] val) where
render _ = mempty
instance {-# INCOHERENT #-}
( R u (One val)
) => R u (T '[ "" ] val) where
render (T x) = render (One x)
instance
( R u (T '[ "" ] b)
, R u (One (Proxy s))
, Semigroup (RenderOutput u)
) => R u (T '[s] (a := b)) where
render (T (AT x)) = render (One (Proxy @ s)) <> render (T 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 x) = render (One (Proxy @ s)) <> render (T 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 x) = render (One (Proxy @ s)) <> render (One x)
instance {-# OVERLAPPING #-}
( R u (T xs val)
) => R u (T ('List xs "") val) where
render (T t) = render (T 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 t) = render (T t :: T xs val) <> render (One (Proxy @ x))
instance
( R u (T (Take (Length b) ps) b)
, R u (T (Drop (Length b) ps) c)
, Semigroup (RenderOutput u)
) => R u (T ps ((a :@: b) c)) where
render (T ~(WithAttributes b c))
= render (T b :: T (Take (Length b) ps) b)
<> render (T c :: T (Drop (Length b) ps) c)
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 ~(a :#: b))
= render (T a :: T (Take (Length a) ps) a)
<> render (T b :: T (Drop (Length a) ps) b)
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 xs)
= render (One (Proxy @ s))
<> foldMap (render . (T :: a -> T (ToList 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 mx)
= render (One (Proxy @ s))
<> foldMap (render . (T :: a -> T (ToList a) 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 eab)
= render (One (Proxy @ s))
<> either (render . (T :: a -> T (ToList a) a)) (render . (T :: b -> T (ToList b) b)) eab