{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
module Html.Function where
import Html.Type
import GHC.Exts
import GHC.TypeLits
import Data.Proxy
import Data.Monoid hiding (Last)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TLB
{-# INLINE render #-}
render :: forall a b.
( Document a
, Escape b
, Monoid b
, IsString b
) => a -> b
render x = render_ (Tagged x :: Tagged (Symbols a) a ())
type Document a =
( Renderchunks (Tagged (Symbols a) a ())
, Renderstring (Tagged (Symbols a) a ())
, KnownSymbol (Last' (Symbols a))
)
{-# RULES
"render_/renderB" render_ = renderB
"render_/renderS" render_ = renderS
"render_/renderLT" render_ = renderLT
#-}
{-# INLINE [2] render_ #-}
render_ :: forall b prox val nex.
( KnownSymbol (Last' prox)
, Renderstring (Tagged prox val nex)
, Renderchunks (Tagged prox val nex)
, Escape b
, Monoid b
, IsString b
) => Tagged prox val nex -> b
render_ x = mconcat $ renderchunks x ++ [closing]
where closing = convert (Proxy :: Proxy (Last' prox))
{-# INLINE renderLT #-}
renderLT :: forall prox val nex.
( KnownSymbol (Last' prox)
, Renderchunks (Tagged prox val nex)
) => Tagged prox val nex -> LT.Text
renderLT x = mconcat $ renderchunks x ++ [closing]
where closing = convert (Proxy :: Proxy (Last' prox))
{-# INLINE renderS #-}
renderS :: forall prox val nex.
( KnownSymbol (Last' prox)
, Renderchunks (Tagged prox val nex)
) => Tagged prox val nex -> String
renderS x = foldr (<>) closing $ renderchunks x
where closing = convert (Proxy :: Proxy (Last' prox))
{-# INLINE renderB #-}
renderB :: forall prox val nex.
( KnownSymbol (Last' prox)
, Renderstring (Tagged prox val nex)
) => Tagged prox val nex -> TLB.Builder
renderB x = renderstring x <> closing
where closing = convert (Proxy :: Proxy (Last' prox))
{-# INLINE addAttributes #-}
addAttributes :: (a ?> b) => [(String, String)] -> (a > b) -> (a :> b)
addAttributes xs (Child b) = WithAttributes (Attributes xs) b
class Renderchunks a where
renderchunks :: (Escape b, IsString b, Monoid b) => a -> [b]
instance KnownSymbol a => Renderchunks (Tagged prox (Proxy a) nex) where
{-# INLINE renderchunks #-}
renderchunks _ = []
instance {-# OVERLAPPABLE #-}
( Convert val
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox val nex) where
{-# INLINE renderchunks #-}
renderchunks (Tagged x)
= convert (Proxy :: Proxy (HeadL prox))
: [convert x]
instance Renderchunks (Tagged prox () nex) where
{-# INLINE renderchunks #-}
renderchunks _ = []
instance
( Renderchunks (Tagged (Take (CountContent a) prox) a b)
, Renderchunks (Tagged (Drop (CountContent a) prox) b nex)
) => Renderchunks (Tagged prox (a # b) nex) where
{-# INLINE renderchunks #-}
renderchunks ~(Tagged (a :#: b))
= renderchunks (Tagged a :: Tagged (Take (CountContent a) prox) a b)
<> renderchunks (Tagged b :: Tagged (Drop (CountContent a) prox) b nex)
instance {-# OVERLAPPING #-}
( Renderchunks (Tagged (Drop 1 prox) (a > b) nex)
, KnownSymbol (HeadL prox)
, a ?> b
) => Renderchunks (Tagged prox (a :> b) nex) where
{-# INLINE renderchunks #-}
renderchunks ~(Tagged (WithAttributes a b))
= convert (Proxy :: Proxy (HeadL prox))
: convert a
: renderchunks (Tagged (Child b) :: Tagged (Drop 1 prox) (a > b) nex)
instance
( Renderchunks (Tagged prox b (Close a))
) => Renderchunks (Tagged prox (a > b) nex) where
{-# INLINE renderchunks #-}
renderchunks ~(Tagged (Child b))
= renderchunks (Tagged b :: Tagged prox b (Close a))
instance
( Renderchunks (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ())
, KnownSymbol (Last' (Symbols (Next (a :> b) nex)))
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox [a :> b] nex) where
{-# INLINE renderchunks #-}
renderchunks (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
: concatMap
(\x -> renderchunks
(Tagged x :: Tagged (Symbols (Next (a :> b) nex)) (a :> b) ())
++ [closing]
) xs
where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a :> b) nex))))
instance
( Renderchunks (Tagged (Symbols (Next (a > b) nex)) (a > b) ())
, KnownSymbol (Last' (Symbols (Next (a > b) nex)))
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox [a > b] nex) where
{-# INLINE renderchunks #-}
renderchunks (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
: concatMap
(\x -> renderchunks
(Tagged x :: Tagged (Symbols (Next (a > b) nex)) (a > b) ())
++ [closing]
) xs
where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a > b) nex))))
instance
( Renderchunks (Tagged (Symbols (Next (a # b) nex)) (a # b) ())
, KnownSymbol (Last' (Symbols (Next (a # b) nex)))
, KnownSymbol (HeadL prox)
) => Renderchunks (Tagged prox [a # b] nex) where
{-# INLINE renderchunks #-}
renderchunks (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
: concatMap
(\x -> renderchunks
(Tagged x :: Tagged (Symbols (Next (a # b) nex)) (a # b) ())
++ [closing]
) xs
where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a # b) nex))))
class Renderstring a where
renderstring :: (Escape b, IsString b, Monoid b) => a -> b
instance KnownSymbol a => Renderstring (Tagged prox (Proxy a) nex) where
{-# INLINE renderstring #-}
renderstring _ = mempty
instance {-# OVERLAPPABLE #-}
( Convert val
, KnownSymbol (HeadL prox)
) => Renderstring (Tagged prox val nex) where
{-# INLINE renderstring #-}
renderstring (Tagged x)
= convert (undefined :: Proxy (HeadL prox))
<> convert x
instance Renderstring (Tagged prox () nex) where
{-# INLINE renderstring #-}
renderstring _ = mempty
instance
( Renderstring (Tagged (Take (CountContent a) prox) a b)
, Renderstring (Tagged (Drop (CountContent a) prox) b nex)
) => Renderstring (Tagged prox (a # b) nex) where
{-# INLINE renderstring #-}
renderstring ~(Tagged (a :#: b))
= renderstring (Tagged a :: Tagged (Take (CountContent a) prox) a b)
<> renderstring (Tagged b :: Tagged (Drop (CountContent a) prox) b nex)
instance {-# OVERLAPPING #-}
( Renderstring (Tagged (Drop 1 prox) (a > b) nex)
, KnownSymbol (HeadL prox)
, a ?> b
) => Renderstring (Tagged prox (a :> b) nex) where
{-# INLINE renderstring #-}
renderstring ~(Tagged (WithAttributes a b))
= convert (Proxy :: Proxy (HeadL prox))
<> convert a
<> renderstring (Tagged (Child b) :: Tagged (Drop 1 prox) (a > b) nex)
instance
( Renderstring (Tagged prox b (Close a))
) => Renderstring (Tagged prox (a > b) nex) where
{-# INLINE renderstring #-}
renderstring ~(Tagged (Child b))
= renderstring (Tagged b :: Tagged prox b (Close a))
instance
( Renderstring (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ())
, Renderchunks (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ())
, KnownSymbol (Last' (Symbols (Next (a :> b) nex)))
, KnownSymbol (HeadL prox)
) => Renderstring (Tagged prox [a :> b] nex) where
{-# INLINE renderstring #-}
renderstring (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
<> foldMap
(\x ->
render_
(Tagged x :: Tagged (Symbols (Next (a :> b) nex)) (a :> b) ())
) xs
instance
( Renderstring (Tagged (Symbols (Next (a > b) nex)) (a > b) ())
, Renderchunks (Tagged (Symbols (Next (a > b) nex)) (a > b) ())
, KnownSymbol (Last' (Symbols (Next (a > b) nex)))
, KnownSymbol (HeadL prox)
) => Renderstring (Tagged prox [a > b] nex) where
{-# INLINE renderstring #-}
renderstring (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
<> foldMap
(\x ->
render_
(Tagged x :: Tagged (Symbols (Next (a > b) nex)) (a > b) ())
) xs
instance
( Renderstring (Tagged (Symbols (Next (a # b) nex)) (a # b) ())
, Renderchunks (Tagged (Symbols (Next (a # b) nex)) (a # b) ())
, KnownSymbol (Last' (Symbols (Next (a # b) nex)))
, KnownSymbol (HeadL prox)
) => Renderstring (Tagged prox [a # b] nex) where
{-# INLINE renderstring #-}
renderstring (Tagged xs)
= convert (undefined :: Proxy (HeadL prox))
<> foldMap
(\x ->
render_
(Tagged x :: Tagged (Symbols (Next (a # b) nex)) (a # b) ())
) xs
{-# RULES
"fromString_/builder" fromString_ = TLB.fromLazyText . LT.pack
#-}
{-# INLINE [2] fromString_ #-}
fromString_ :: IsString a => String -> a
fromString_ = fromString
{-# RULES
"convert/a/a" forall f. convert_ f = escape
"convert/string/builder" forall f. convert_ f = TLB.fromLazyText . escape . LT.pack
"convert/lazy text/builder" forall f. convert_ f = TLB.fromLazyText . escape
"convert/strict text/builder" forall f. convert_ f = TLB.fromText . escape
"convert/builder/lazy text" forall f. convert_ f = escape . TLB.toLazyText
"convert/lazy text/strict text" forall f. convert_ f = LT.toStrict . escape
"convert/strict text/lazy text" forall f. convert_ f = escape . LT.fromStrict
#-}
{-# INLINE [1] convert_ #-}
convert_ :: (Escape b, IsString a, IsString b) => (a -> b) -> (a -> b)
convert_ f = escape . f
class (IsString a, Monoid a) => Escape a where
escape :: a -> a
instance Escape TLB.Builder where
escape
= TLB.fromLazyText
. escape
. TLB.toLazyText
instance Escape T.Text where
escape = T.foldr f mempty
where
f '<' b = "<" <> b
f '>' b = ">" <> b
f '&' b = "&" <> b
f '"' b = """ <> b
f '\'' b = "'" <> b
f x b = T.singleton x <> b
instance Escape LT.Text where
escape = foldr (<>) "" . LT.foldr f []
where
f '<' b = "<" : b
f '>' b = ">" : b
f '&' b = "&" : b
f '"' b = """ : b
f '\'' b = "'" : b
f x b = LT.singleton x : b
instance Escape String where
escape = concatMap f
where
f '<' = "<"
f '>' = ">"
f '&' = "&"
f '"' = """
f '\'' = "'"
f x = [x]
class Convert a where
convert :: (Escape b, IsString b, Monoid b) => a -> b
instance KnownSymbol a => Convert (Proxy a) where
{-# INLINE convert #-}
convert = fromString_ . symbolVal
instance Convert a => Convert (Maybe a) where
{-# INLINE convert #-}
convert Nothing = ""
convert (Just x) = convert x
instance Convert Attributes where
{-# INLINE convert #-}
convert ~(Attributes xs) = fromString $ concat [ ' ' : a ++ "=\"" ++ escape b ++ "\"" | (a,b) <- xs]
instance Convert String where
{-# INLINE convert #-}
convert = convert_ fromString
instance Convert T.Text where
{-# INLINE convert #-}
convert = convert_ (fromString . T.unpack)
instance Convert LT.Text where
{-# INLINE convert #-}
convert = convert_ (fromString . LT.unpack)
instance Convert TLB.Builder where
{-# INLINE convert #-}
convert = convert_ (fromString . LT.unpack . TLB.toLazyText)
instance Convert Int where
{-# INLINE convert #-}
convert = fromString . show
instance Convert Integer where
{-# INLINE convert #-}
convert = fromString . show
instance Convert Float where
{-# INLINE convert #-}
convert = fromString . show
instance Convert Double where
{-# INLINE convert #-}
convert = fromString . show
instance Convert Word where
{-# INLINE convert #-}
convert = fromString . show
instance Document (a # b) => Show (a # b) where show = render
instance {-# OVERLAPPING #-} Document [a # b] => Show [a # b] where show = render
instance Document (a > b) => Show (a > b) where show = render
instance {-# OVERLAPPING #-} Document [a > b] => Show [a > b] where show = render
instance Document (a :> b) => Show (a :> b) where show = render
instance {-# OVERLAPPING #-} Document [a :> b] => Show [a :> b] where show = render