{-# 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))

-- | Constraint for compactable html documents.  It's a type family to avoid an
-- error about FlexibleContexts and a warning about MonoLocalBinds.
type family Compactable a where Compactable a = Compactable' a

-- | Data for putting variables into a rendered compacted html document.
data Put (n :: Symbol) = forall a. Convert a => Put a

-- | Type of a rendered compact html which determines the amount of arguments.
type family Retrieve f xs where
  Retrieve f (x ': xs) = Put x -> Retrieve f xs
  Retrieve f '[] = f

-- | List of Symbols for which a render function can be created.
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)

-- | Constraint for html documents.  It's a type family to avoid an
-- error about FlexibleContexts and a warning about MonoLocalBinds.
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)))

-- | Common instances

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