{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.HyperView.Handled where

import Data.Kind (Constraint, Type)
import GHC.TypeLits hiding (Mod)
import Web.Atomic.Types
import Web.Hyperbole.Data.Encoded as Encoded
import Web.Hyperbole.HyperView.Types
import Web.Hyperbole.HyperView.ViewId
import Web.Hyperbole.TypeList
import Web.Hyperbole.View (View, addContext, tag)


{- | Embed a 'HyperView' into a page or another 'View'

@
page :: 'Page' es '[Message]
page = do
  pure $ do
    'el' \"Unchanging Header\"
    'hyper' Message $ messageView \"Hello World\"
@
-}
hyper
  :: forall id ctx
   . (HyperViewHandled id ctx, ViewId id)
  => id
  -> View id ()
  -> View ctx ()
hyper :: forall id ctx.
(HyperViewHandled id ctx, ViewId id) =>
id -> View id () -> View ctx ()
hyper = id -> View id () -> View ctx ()
forall id ctx. ViewId id => id -> View id () -> View ctx ()
hyperUnsafe


hyperUnsafe :: (ViewId id) => id -> View id () -> View ctx ()
hyperUnsafe :: forall id ctx. ViewId id => id -> View id () -> View ctx ()
hyperUnsafe id
vid View id ()
vw = do
  Text -> View ctx () -> View ctx ()
forall c. Text -> View c () -> View c ()
tag Text
"div" (View ctx () -> View ctx ())
-> (Attributes (View ctx () -> View ctx ())
    -> Attributes (View ctx () -> View ctx ()))
-> View ctx ()
-> View ctx ()
forall h.
Attributable h =>
h -> (Attributes h -> Attributes h) -> h
@ Text
-> Text
-> Attributes (View ctx () -> View ctx ())
-> Attributes (View ctx () -> View ctx ())
forall h.
Attributable h =>
Text -> Text -> Attributes h -> Attributes h
att Text
"id" (Encoded -> Text
encodedToText (Encoded -> Text) -> Encoded -> Text
forall a b. (a -> b) -> a -> b
$ id -> Encoded
forall a. ViewId a => a -> Encoded
toViewId id
vid) (View ctx () -> View ctx ()) -> View ctx () -> View ctx ()
forall a b. (a -> b) -> a -> b
$
    id -> View id () -> View ctx ()
forall ctx c. ctx -> View ctx () -> View c ()
addContext id
vid View id ()
vw


type family ValidDescendents x :: [Type] where
  ValidDescendents x = x : NextDescendents '[] '[x]


type family NextDescendents (ex :: [Type]) (xs :: [Type]) where
  NextDescendents _ '[] = '[]
  NextDescendents ex (x ': xs) =
    RemoveAll (x : ex) (Require x)
      <++> NextDescendents ((x : ex) <++> Require x) (RemoveAll (x : ex) (Require x))
      <++> NextDescendents (x : ex) (RemoveAll (x : ex) xs)


type NotHandled id ctx (views :: [Type]) =
  TypeError
    ( 'Text "HyperView "
        :<>: 'ShowType id
        :<>: 'Text " not found in (Require "
        :<>: 'ShowType ctx
        :<>: 'Text ")"
        :$$: 'Text "  "
          :<>: 'ShowType views
        :$$: 'Text "Try adding it to the HyperView instance:"
        :$$: 'Text "  instance HyperView "
          :<>: 'ShowType ctx
          :<>: 'Text " where"
        :$$: 'Text "    type Action "
          :<>: 'ShowType ctx
          :<>: 'Text " = "
          :<>: ShowType (Action id)
          :<>: 'Text ""
        :$$: 'Text "    type Require "
          :<>: 'ShowType ctx
          :<>: 'Text " = ["
          :<>: ShowType id
          :<>: 'Text ", ...]"
    )


type NotDesc id ctx x cs =
  TypeError
    ( 'Text ""
        :<>: 'ShowType x
        :<>: 'Text ", a child of HyperView "
        :<>: 'ShowType id
        :<>: 'Text ", not handled by context "
        :<>: 'ShowType ctx
        :$$: ('Text " Require = " ':<>: 'ShowType cs)
        -- ':$$: 'ShowType x
        -- ':$$: 'ShowType cs
    )


type NotInPage x total =
  TypeError
    ( 'Text ""
        :<>: 'ShowType x
        :<>: 'Text " not included in: "
        :$$: 'Text "  Page es "
          :<>: ShowType total
        :$$: 'Text "try expanding the page views to:"
        :$$: 'Text "  Page es "
          :<>: ShowType (x : total)
          -- :$$: 'Text " " :<>: 'ShowType ctx :<>: 'Text " = " :<>: ShowType (Action id) :<>: 'Text ""
          -- :$$: 'Text "    page :: (Hyperbole :> es) => Page es '[" :<>: 'ShowType ctx :<>: 'Text " = [" :<>: ShowType id :<>: 'Text ", ...]"
    )


type HyperViewHandled id ctx =
  ( -- the id must be found in the children of the context
    ElemOr id (ctx : Require ctx) (NotHandled id ctx (Require ctx))
  , -- Make sure the descendents of id are in the context for the root page
    CheckDescendents id ctx
  )


-- TODO: Report which view requires the missing one
type family CheckDescendents id ctx :: Constraint where
  CheckDescendents id (Root total) =
    ( AllInPage (ValidDescendents id) total
    )
  CheckDescendents id ctx = ()


type family AllInPage ids total :: Constraint where
  AllInPage '[] _ = ()
  AllInPage (x ': xs) total =
    (ElemOr x total (NotInPage x total), AllInPage xs total)