{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module Html.Reify where
import Html.Type
import Html.Convert
import GHC.TypeLits
import Data.Proxy
import Data.Semigroup
import Data.String
import qualified Data.Text.Lazy as T
import qualified Data.ByteString.Lazy as B
{-# INLINE render #-}
render :: forall a b. Document a b => a -> b
render x = mconcat $ renderchunks (Tagged x :: Tagged (Symbols a) a ())
<> [unConv (conv (Proxy @ (Last' (Symbols a))))]
{-# INLINE renderString #-}
renderString :: Document a String => a -> String
renderString = render
{-# INLINE renderText #-}
renderText :: Document a T.Text => a -> T.Text
renderText = render
{-# INLINE renderByteString #-}
renderByteString :: Document a B.ByteString => a -> B.ByteString
renderByteString = render
type Document a b =
( Renderchunks (Tagged (Symbols a) a ()) b
, KnownSymbol (Last' (Symbols a))
, Conv b
, Monoid b
)
class Renderchunks a b where
renderchunks :: a -> [b]
instance KnownSymbol a => Renderchunks (Tagged prox (Proxy a) nex) b where
{-# INLINE renderchunks #-}
renderchunks _ = mempty
instance Renderchunks (Tagged prox () nex) b where
{-# INLINE renderchunks #-}
renderchunks _ = mempty
instance {-# OVERLAPPABLE #-}
( Convert val
, Conv u
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox val nex) u where
{-# INLINE renderchunks #-}
renderchunks (Tagged x)
= unConv (conv (Proxy @ (HeadL prox)))
: [unConv (conv x)]
instance
( t ~ Tagged prox b (Close a)
, Renderchunks t u
) => Renderchunks (Tagged prox (a > b) nex) u where
{-# INLINE renderchunks #-}
renderchunks (Tagged ~(Child b)) = renderchunks (Tagged b :: t)
instance
( t ~ Tagged (Drop 1 prox) b (Close a)
, Renderchunks t u
, Conv u
, Monoid u
, IsString u
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox (a :> b) nex) u where
{-# INLINE renderchunks #-}
renderchunks (Tagged (WithAttributes xs b))
= unConv (conv (Proxy @ (HeadL prox)))
: foldMap (unConv . conv . Raw . (\(Attribute x) -> x)) xs
: renderchunks (Tagged b :: t)
instance
( t1 ~ Tagged (Take (CountContent a) prox) a b
, t2 ~ Tagged (Drop (CountContent a) prox) b nex
, Renderchunks t1 u
, Renderchunks t2 u
, Monoid u
) => Renderchunks (Tagged prox (a # b) nex) u where
{-# INLINE renderchunks #-}
renderchunks (Tagged ~(a :#: b))
= mconcat (renderchunks (Tagged a :: t1)) : renderchunks (Tagged b :: t2)
instance
( t1 ~ Tagged t2 (a `f` b) ()
, t2 ~ Symbols (Next (a `f` b) nex)
, Renderchunks t1 u
, Conv u
, KnownSymbol (Last' t2)
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox [a `f` b] nex) u where
{-# INLINE renderchunks #-}
renderchunks (Tagged xs)
= unConv (conv (Proxy @ (HeadL prox)))
: Prelude.concatMap (\x -> renderchunks (Tagged x :: t1) <> [closing]) xs
where closing = unConv (conv (Proxy @ (Last' t2)))