{-# 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.Data.QueryData (ParamValue (..), readQueryParam, showQueryParam)
import Web.Hyperbole.Effect.Hyperbole (Hyperbole)
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
  deriving (Show, Read, 'ViewId')

instance 'HyperView' Message es where
  data 'Action' Message
    = SetMessage Text
    deriving (Show, Read, 'ViewAction')

  'update' (SetMessage msg) =
    pure $ messageView msg
@
-}
class (ViewId id, ViewAction (Action id)) => HyperView id es where
  -- | Outline all actions that are permitted in this HyperView
  --
  -- > data Action Message = SetMessage Text | ClearMessage
  -- >   deriving (Show, Read, ViewAction)
  data Action id


  -- | Include any child hyperviews here. The compiler will make sure that the page knows how to handle them
  --
  -- > type Require = '[ChildView]
  type Require id :: [Type]


  type Require id = '[]


  -- | Specify how the view should be updated for each Action
  --
  -- > update (SetMessage msg) = pure $ messageView msg
  -- > update ClearMessage = pure $ messageView ""
  update :: (Hyperbole :> es) => Action id -> Eff (Reader id : es) (View id ())


-- | The top-level view returned by a 'Page'. It carries a type-level list of every 'HyperView' used in our 'Page' so the compiler can check our work and wire everything together.
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)


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

@
page :: 'Eff' es ('Page' '[Message])
page = do
  pure $ do
    col (pad 10 . gap 10) $ do
      'el' (bold . fontSize 24) \"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
  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 = (.text) (ParamValue -> Text) -> (a -> ParamValue) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ParamValue
forall a. Show a => a -> ParamValue
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
$ ParamValue -> Either Text a
forall a. Read a => ParamValue -> Either Text a
readQueryParam (Text -> ParamValue
ParamValue 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 = (.text) (ParamValue -> Text) -> (a -> ParamValue) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ParamValue
forall a. Show a => a -> ParamValue
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
$ ParamValue -> Either Text a
forall a. Read a => ParamValue -> Either Text a
readQueryParam (Text -> ParamValue
ParamValue Text
t)


{- | Access the 'viewId' in a 'View' or 'update'

@
data Contact = Contact UserId
  deriving (Show, Read, 'ViewId')

instance (Users :> es, Debug :> es) => 'HyperView' Contact es where
  data 'Action' Contact
    = Edit
    | Save
    | 'View'
    deriving (Show, Read, 'ViewAction')

  'update' action = do
    -- No matter which action we are performing, let's look up the user to make sure it exists
    Contact uid <- 'viewId'
    u <- Users.find uid
    case action of
      'View' -> do
        pure $ contactView u
      Edit -> do
        pure $ contactEditView u
      Save -> do
        delay 1000
        unew <- parseUser uid
        Users.save unew
        pure $ contactView unew
@
-}
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