{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.HyperView where

import Data.Kind (Constraint, Type)
import Data.Text (Text)
import Effectful
import Effectful.Reader.Dynamic
import GHC.TypeLits hiding (Mod)
import Web.Hyperbole.Effect.Hyperbole (Hyperbole)
import Web.Hyperbole.Effect.QueryData (readQueryParam, showQueryParam)
import Web.Hyperbole.TypeList
import Web.View (View, addContext, att, context, el, flexCol, none)


{- | HyperViews are interactive subsections of a 'Page'

Create an instance with a unique view id type and a sum type describing the actions the HyperView supports. The View Id can contain context (a database id, for example)

@
data Message = Message Int
  deriving (Generic, 'Param')

data MessageAction
  = Louder Text
  | ClearMessage
  deriving (Generic, 'Param')

instance HyperView Message where
  type Action Message = MessageAction
@
-}
class (ViewId id, ViewAction (Action id)) => HyperView id es where
  data Action id


  type Require id :: [Type]
  type Require id = '[]


  update :: (Hyperbole :> es) => Action id -> Eff (Reader id : es) (View id ())


-- | The top-level view created by 'load'. Carries the views in its type to check that we handled all our views
data Root (views :: [Type]) = Root
  deriving (Int -> Root views -> ShowS
[Root views] -> ShowS
Root views -> String
(Int -> Root views -> ShowS)
-> (Root views -> String)
-> ([Root views] -> ShowS)
-> Show (Root views)
forall (views :: [*]). Int -> Root views -> ShowS
forall (views :: [*]). [Root views] -> ShowS
forall (views :: [*]). Root views -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (views :: [*]). Int -> Root views -> ShowS
showsPrec :: Int -> Root views -> ShowS
$cshow :: forall (views :: [*]). Root views -> String
show :: Root views -> String
$cshowList :: forall (views :: [*]). [Root views] -> ShowS
showList :: [Root views] -> ShowS
Show, ReadPrec [Root views]
ReadPrec (Root views)
Int -> ReadS (Root views)
ReadS [Root views]
(Int -> ReadS (Root views))
-> ReadS [Root views]
-> ReadPrec (Root views)
-> ReadPrec [Root views]
-> Read (Root views)
forall (views :: [*]). ReadPrec [Root views]
forall (views :: [*]). ReadPrec (Root views)
forall (views :: [*]). Int -> ReadS (Root views)
forall (views :: [*]). ReadS [Root views]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall (views :: [*]). Int -> ReadS (Root views)
readsPrec :: Int -> ReadS (Root views)
$creadList :: forall (views :: [*]). ReadS [Root views]
readList :: ReadS [Root views]
$creadPrec :: forall (views :: [*]). ReadPrec (Root views)
readPrec :: ReadPrec (Root views)
$creadListPrec :: forall (views :: [*]). ReadPrec [Root views]
readListPrec :: ReadPrec [Root views]
Read, Text -> Maybe (Root views)
Root views -> Text
(Root views -> Text)
-> (Text -> Maybe (Root views)) -> ViewId (Root views)
forall (views :: [*]). Text -> Maybe (Root views)
forall (views :: [*]). Root views -> Text
forall a. (a -> Text) -> (Text -> Maybe a) -> ViewId a
$ctoViewId :: forall (views :: [*]). Root views -> Text
toViewId :: Root views -> Text
$cparseViewId :: forall (views :: [*]). Text -> Maybe (Root views)
parseViewId :: Text -> Maybe (Root views)
ViewId)


instance HyperView (Root views) es where
  data Action (Root views) = RootNone
    deriving (Int -> Action (Root views) -> ShowS
[Action (Root views)] -> ShowS
Action (Root views) -> String
(Int -> Action (Root views) -> ShowS)
-> (Action (Root views) -> String)
-> ([Action (Root views)] -> ShowS)
-> Show (Action (Root views))
forall (views :: [*]). Int -> Action (Root views) -> ShowS
forall (views :: [*]). [Action (Root views)] -> ShowS
forall (views :: [*]). Action (Root views) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (views :: [*]). Int -> Action (Root views) -> ShowS
showsPrec :: Int -> Action (Root views) -> ShowS
$cshow :: forall (views :: [*]). Action (Root views) -> String
show :: Action (Root views) -> String
$cshowList :: forall (views :: [*]). [Action (Root views)] -> ShowS
showList :: [Action (Root views)] -> ShowS
Show, ReadPrec [Action (Root views)]
ReadPrec (Action (Root views))
Int -> ReadS (Action (Root views))
ReadS [Action (Root views)]
(Int -> ReadS (Action (Root views)))
-> ReadS [Action (Root views)]
-> ReadPrec (Action (Root views))
-> ReadPrec [Action (Root views)]
-> Read (Action (Root views))
forall (views :: [*]). ReadPrec [Action (Root views)]
forall (views :: [*]). ReadPrec (Action (Root views))
forall (views :: [*]). Int -> ReadS (Action (Root views))
forall (views :: [*]). ReadS [Action (Root views)]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall (views :: [*]). Int -> ReadS (Action (Root views))
readsPrec :: Int -> ReadS (Action (Root views))
$creadList :: forall (views :: [*]). ReadS [Action (Root views)]
readList :: ReadS [Action (Root views)]
$creadPrec :: forall (views :: [*]). ReadPrec (Action (Root views))
readPrec :: ReadPrec (Action (Root views))
$creadListPrec :: forall (views :: [*]). ReadPrec [Action (Root views)]
readListPrec :: ReadPrec [Action (Root views)]
Read, Text -> Maybe (Action (Root views))
Action (Root views) -> Text
(Action (Root views) -> Text)
-> (Text -> Maybe (Action (Root views)))
-> ViewAction (Action (Root views))
forall (views :: [*]). Text -> Maybe (Action (Root views))
forall (views :: [*]). Action (Root views) -> Text
forall a. (a -> Text) -> (Text -> Maybe a) -> ViewAction a
$ctoAction :: forall (views :: [*]). Action (Root views) -> Text
toAction :: Action (Root views) -> Text
$cparseAction :: forall (views :: [*]). Text -> Maybe (Action (Root views))
parseAction :: Text -> Maybe (Action (Root views))
ViewAction)
  type Require (Root views) = views
  update :: (Hyperbole :> es) =>
Action (Root views)
-> Eff (Reader (Root views) : es) (View (Root views) ())
update Action (Root views)
_ = View (Root views) ()
-> Eff (Reader (Root views) : es) (View (Root views) ())
forall a. a -> Eff (Reader (Root views) : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure View (Root views) ()
forall c. View c ()
none


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 (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)


-- TODO: if I'm going to limit it, it's going to happen here
-- AND all their children have to be there
-- , All (Elem (Require ctx)) (Require id)
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
  Mod ctx -> View ctx () -> View ctx ()
forall c. Mod c -> View c () -> View c ()
el (Text -> Text -> Mod ctx
forall c. Text -> Text -> Mod c
att Text
"id" (id -> Text
forall a. ViewId a => a -> Text
toViewId id
vid) Mod ctx -> Mod ctx -> Mod ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod ctx
forall c. Mod c
flexCol) (View ctx () -> View ctx ()) -> View ctx () -> View ctx ()
forall a b. (a -> b) -> a -> b
$
    id -> View id () -> View ctx ()
forall context c. context -> View context () -> View c ()
addContext id
vid View id ()
vw


class ViewAction a where
  toAction :: a -> Text
  default toAction :: (Show a) => a -> Text
  toAction = a -> Text
forall a. Show a => a -> Text
showQueryParam


  parseAction :: Text -> Maybe a
  default parseAction :: (Read a) => Text -> Maybe a
  parseAction Text
t =
    (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> Maybe a) -> Either Text a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a. Read a => Text -> Either Text a
readQueryParam Text
t


instance ViewAction () where
  toAction :: () -> Text
toAction ()
_ = Text
""
  parseAction :: Text -> Maybe ()
parseAction Text
_ = () -> Maybe ()
forall a. a -> Maybe a
Just ()


class ViewId a where
  toViewId :: a -> Text
  default toViewId :: (Show a) => a -> Text
  toViewId = a -> Text
forall a. Show a => a -> Text
showQueryParam


  parseViewId :: Text -> Maybe a
  default parseViewId :: (Read a) => Text -> Maybe a
  parseViewId Text
t =
    (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> Maybe a) -> Either Text a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a. Read a => Text -> Either Text a
readQueryParam Text
t


class HasViewId m view where
  viewId :: m view
instance HasViewId (View ctx) ctx where
  viewId :: View ctx ctx
viewId = View ctx ctx
forall ctx. View ctx ctx
context
instance HasViewId (Eff (Reader view : es)) view where
  viewId :: Eff (Reader view : es) view
viewId = Eff (Reader view : es) view
forall r (es :: [Effect]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask