{-# LANGUAGE AllowAmbiguousTypes #-}

module Web.Hyperbole.View.Types where

import Data.String (IsString (..))
import Data.Text (Text, pack)
import Effectful
import Effectful.Reader.Dynamic
import Effectful.State.Dynamic
import GHC.Generics
import Web.Atomic.Html (Html (..))
import Web.Atomic.Html qualified as Atomic
import Web.Atomic.Types
import Web.Hyperbole.Data.Encoded (decodeEither, encodedToText)
import Web.Hyperbole.Data.Param (FromParam, ToParam (..))
import Web.Hyperbole.View.ViewId


-- View ------------------------------------------------------------

{- | 'View's are HTML fragments with a 'context'

@
helloWorld :: 'View' context ()
helloWorld =
  'el' \"Hello World\"
@
-}
newtype View c a = View {forall c a. View c a -> Eff '[Reader (c, ViewState c)] (Html a)
html :: Eff '[Reader (c, ViewState c)] (Html a)}


instance IsString (View c ()) where
  fromString :: String -> View c ()
fromString String
s = Eff '[Reader (c, ViewState c)] (Html ()) -> View c ()
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html ()) -> View c ())
-> Eff '[Reader (c, ViewState c)] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ Html () -> Eff '[Reader (c, ViewState c)] (Html ())
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader (c, ViewState c)] (Html ()))
-> Html () -> Eff '[Reader (c, ViewState c)] (Html ())
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
Atomic.text (String -> Text
pack String
s)


execView :: forall c a. c -> ViewState c -> View c a -> Html a
execView :: forall c a. c -> ViewState c -> View c a -> Html a
execView c
c ViewState c
st (View Eff '[Reader (c, ViewState c)] (Html a)
eff) = do
  Eff '[] (Html a) -> Html a
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Html a) -> Html a) -> Eff '[] (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ (c, ViewState c)
-> Eff '[Reader (c, ViewState c)] (Html a) -> Eff '[] (Html a)
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader (c
c, ViewState c
st) Eff '[Reader (c, ViewState c)] (Html a)
eff


instance Functor (View c) where
  fmap :: forall a b. (a -> b) -> View c a -> View c b
fmap a -> b
f (View Eff '[Reader (c, ViewState c)] (Html a)
eff) = Eff '[Reader (c, ViewState c)] (Html b) -> View c b
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html b) -> View c b)
-> Eff '[Reader (c, ViewState c)] (Html b) -> View c b
forall a b. (a -> b) -> a -> b
$ do
    Html a
html <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    Html b -> Eff '[Reader (c, ViewState c)] (Html b)
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html b -> Eff '[Reader (c, ViewState c)] (Html b))
-> Html b -> Eff '[Reader (c, ViewState c)] (Html b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Html a -> Html b
forall a b. (a -> b) -> Html a -> Html b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Html a
html
instance Applicative (View ctx) where
  pure :: forall a. a -> View ctx a
pure a
a = Eff '[Reader (ctx, ViewState ctx)] (Html a) -> View ctx a
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (ctx, ViewState ctx)] (Html a) -> View ctx a)
-> Eff '[Reader (ctx, ViewState ctx)] (Html a) -> View ctx a
forall a b. (a -> b) -> a -> b
$ Html a -> Eff '[Reader (ctx, ViewState ctx)] (Html a)
forall a. a -> Eff '[Reader (ctx, ViewState ctx)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader (ctx, ViewState ctx)] (Html a))
-> Html a -> Eff '[Reader (ctx, ViewState ctx)] (Html a)
forall a b. (a -> b) -> a -> b
$ a -> Html a
forall a. a -> Html a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  liftA2 :: (a -> b -> c) -> View ctx a -> View ctx b -> View ctx c
  liftA2 :: forall a b c.
(a -> b -> c) -> View ctx a -> View ctx b -> View ctx c
liftA2 a -> b -> c
abc (View Eff '[Reader (ctx, ViewState ctx)] (Html a)
va) (View Eff '[Reader (ctx, ViewState ctx)] (Html b)
vb) = Eff '[Reader (ctx, ViewState ctx)] (Html c) -> View ctx c
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (ctx, ViewState ctx)] (Html c) -> View ctx c)
-> Eff '[Reader (ctx, ViewState ctx)] (Html c) -> View ctx c
forall a b. (a -> b) -> a -> b
$ do
    Html a
ha <- Eff '[Reader (ctx, ViewState ctx)] (Html a)
va
    Html b
hb <- Eff '[Reader (ctx, ViewState ctx)] (Html b)
vb
    Html c -> Eff '[Reader (ctx, ViewState ctx)] (Html c)
forall a. a -> Eff '[Reader (ctx, ViewState ctx)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html c -> Eff '[Reader (ctx, ViewState ctx)] (Html c))
-> Html c -> Eff '[Reader (ctx, ViewState ctx)] (Html c)
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> Html a -> Html b -> Html c
forall a b c. (a -> b -> c) -> Html a -> Html b -> Html c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
abc Html a
ha Html b
hb
  View Eff '[Reader (ctx, ViewState ctx)] (Html a)
va *> :: forall a b. View ctx a -> View ctx b -> View ctx b
*> View Eff '[Reader (ctx, ViewState ctx)] (Html b)
vb = Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b)
-> Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b
forall a b. (a -> b) -> a -> b
$ do
    Html a
ha <- Eff '[Reader (ctx, ViewState ctx)] (Html a)
va
    Html b
hb <- Eff '[Reader (ctx, ViewState ctx)] (Html b)
vb
    Html b -> Eff '[Reader (ctx, ViewState ctx)] (Html b)
forall a. a -> Eff '[Reader (ctx, ViewState ctx)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html b -> Eff '[Reader (ctx, ViewState ctx)] (Html b))
-> Html b -> Eff '[Reader (ctx, ViewState ctx)] (Html b)
forall a b. (a -> b) -> a -> b
$ Html a
ha Html a -> Html b -> Html b
forall a b. Html a -> Html b -> Html b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Html b
hb
instance Monad (View ctx) where
  >> :: forall a b. View ctx a -> View ctx b -> View ctx b
(>>) = View ctx a -> View ctx b -> View ctx b
forall a b. View ctx a -> View ctx b -> View ctx b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  (>>=) :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b
  -- TEST: appending Empty
  View Eff '[Reader (ctx, ViewState ctx)] (Html a)
ea >>= :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b
>>= a -> View ctx b
famb = Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b)
-> Eff '[Reader (ctx, ViewState ctx)] (Html b) -> View ctx b
forall a b. (a -> b) -> a -> b
$ do
    a
a :: a <- (.value) (Html a -> a)
-> Eff '[Reader (ctx, ViewState ctx)] (Html a)
-> Eff '[Reader (ctx, ViewState ctx)] a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff '[Reader (ctx, ViewState ctx)] (Html a)
ea
    let View Eff '[Reader (ctx, ViewState ctx)] (Html b)
eb :: View ctx b = a -> View ctx b
famb a
a
    Eff '[Reader (ctx, ViewState ctx)] (Html b)
eb


-- Context -----------------------------------------

-- type family ViewContext (v :: Type) where
--   ViewContext (View c x) = c
--   ViewContext (View c x -> View c x) = c

newtype ChildView a = ChildView a
  deriving ((forall x. ChildView a -> Rep (ChildView a) x)
-> (forall x. Rep (ChildView a) x -> ChildView a)
-> Generic (ChildView a)
forall x. Rep (ChildView a) x -> ChildView a
forall x. ChildView a -> Rep (ChildView a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ChildView a) x -> ChildView a
forall a x. ChildView a -> Rep (ChildView a) x
$cfrom :: forall a x. ChildView a -> Rep (ChildView a) x
from :: forall x. ChildView a -> Rep (ChildView a) x
$cto :: forall a x. Rep (ChildView a) x -> ChildView a
to :: forall x. Rep (ChildView a) x -> ChildView a
Generic)
instance (ViewId a, FromParam a, ToParam a) => ViewId (ChildView a) where
  type ViewState (ChildView a) = ViewState a


-- TEST: appending Empty
context :: forall c. View c (c, ViewState c)
context :: forall c. View c (c, ViewState c)
context = Eff '[Reader (c, ViewState c)] (Html (c, ViewState c))
-> View c (c, ViewState c)
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html (c, ViewState c))
 -> View c (c, ViewState c))
-> Eff '[Reader (c, ViewState c)] (Html (c, ViewState c))
-> View c (c, ViewState c)
forall a b. (a -> b) -> a -> b
$ do
  (c, ViewState c)
c <- forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @(c, ViewState c)
  Html (c, ViewState c)
-> Eff '[Reader (c, ViewState c)] (Html (c, ViewState c))
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html (c, ViewState c)
 -> Eff '[Reader (c, ViewState c)] (Html (c, ViewState c)))
-> Html (c, ViewState c)
-> Eff '[Reader (c, ViewState c)] (Html (c, ViewState c))
forall a b. (a -> b) -> a -> b
$ (c, ViewState c) -> Html (c, ViewState c)
forall a. a -> Html a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c, ViewState c)
c


viewState :: View c (ViewState c)
viewState :: forall c. View c (ViewState c)
viewState = (c, ViewState c) -> ViewState c
forall a b. (a, b) -> b
snd ((c, ViewState c) -> ViewState c)
-> View c (c, ViewState c) -> View c (ViewState c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> View c (c, ViewState c)
forall c. View c (c, ViewState c)
context


runViewContext :: ctx -> ViewState ctx -> View ctx () -> View c ()
runViewContext :: forall ctx c. ctx -> ViewState ctx -> View ctx () -> View c ()
runViewContext ctx
c ViewState ctx
st (View Eff '[Reader (ctx, ViewState ctx)] (Html ())
eff) = Eff '[Reader (c, ViewState c)] (Html ()) -> View c ()
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html ()) -> View c ())
-> Eff '[Reader (c, ViewState c)] (Html ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ do
  Html () -> Eff '[Reader (c, ViewState c)] (Html ())
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html () -> Eff '[Reader (c, ViewState c)] (Html ()))
-> Html () -> Eff '[Reader (c, ViewState c)] (Html ())
forall a b. (a -> b) -> a -> b
$ Eff '[] (Html ()) -> Html ()
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Html ()) -> Html ()) -> Eff '[] (Html ()) -> Html ()
forall a b. (a -> b) -> a -> b
$ (ctx, ViewState ctx)
-> Eff '[Reader (ctx, ViewState ctx)] (Html ())
-> Eff '[] (Html ())
forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader (ctx
c, ViewState ctx
st) Eff '[Reader (ctx, ViewState ctx)] (Html ())
eff


runChildView :: (ViewState ctx ~ ViewState c) => (c -> ctx) -> View ctx () -> View c ()
runChildView :: forall ctx c.
(ViewState ctx ~ ViewState c) =>
(c -> ctx) -> View ctx () -> View c ()
runChildView c -> ctx
f View ctx ()
v = do
  ViewState c
st <- View c (ViewState c)
forall c. View c (ViewState c)
viewState
  c
c <- View c c
forall {k} (m :: k -> *) (view :: k). HasViewId m view => m view
viewId
  ctx -> ViewState ctx -> View ctx () -> View c ()
forall ctx c. ctx -> ViewState ctx -> View ctx () -> View c ()
runViewContext (c -> ctx
f c
c) ViewState ctx
ViewState c
st View ctx ()
v


-- modifyContext
--   :: forall ctx0 ctx1. (ctx0 -> ctx1) -> View ctx1 () -> View ctx0 ()
-- modifyContext f (View eff) = View $ do
--   ctx0 <- ask @ctx0
--   pure $ runPureEff $ runReader (f ctx0) eff

-- Attributes -----------------------------------------

instance Attributable (View c a) where
  modAttributes :: (Map Text Text -> Map Text Text) -> View c a -> View c a
modAttributes Map Text Text -> Map Text Text
f (View Eff '[Reader (c, ViewState c)] (Html a)
eff) = Eff '[Reader (c, ViewState c)] (Html a) -> View c a
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html a) -> View c a)
-> Eff '[Reader (c, ViewState c)] (Html a) -> View c a
forall a b. (a -> b) -> a -> b
$ do
    Html a
h <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    Html a -> Eff '[Reader (c, ViewState c)] (Html a)
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader (c, ViewState c)] (Html a))
-> Html a -> Eff '[Reader (c, ViewState c)] (Html a)
forall a b. (a -> b) -> a -> b
$ (Map Text Text -> Map Text Text) -> Html a -> Html a
forall h.
Attributable h =>
(Map Text Text -> Map Text Text) -> h -> h
modAttributes Map Text Text -> Map Text Text
f Html a
h


instance Styleable (View c a) where
  modCSS :: ([Rule] -> [Rule]) -> View c a -> View c a
modCSS [Rule] -> [Rule]
f (View Eff '[Reader (c, ViewState c)] (Html a)
eff) = Eff '[Reader (c, ViewState c)] (Html a) -> View c a
forall c a. Eff '[Reader (c, ViewState c)] (Html a) -> View c a
View (Eff '[Reader (c, ViewState c)] (Html a) -> View c a)
-> Eff '[Reader (c, ViewState c)] (Html a) -> View c a
forall a b. (a -> b) -> a -> b
$ do
    Html a
h <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    Html a -> Eff '[Reader (c, ViewState c)] (Html a)
forall a. a -> Eff '[Reader (c, ViewState c)] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html a -> Eff '[Reader (c, ViewState c)] (Html a))
-> Html a -> Eff '[Reader (c, ViewState c)] (Html a)
forall a b. (a -> b) -> a -> b
$ ([Rule] -> [Rule]) -> Html a -> Html a
forall h. Styleable h => ([Rule] -> [Rule]) -> h -> h
modCSS [Rule] -> [Rule]
f Html a
h


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

@
data LazyData = LazyData TaskId
  deriving (Generic, 'ViewId')

instance (Debug :> es, GenRandom :> es) => 'HyperView' LazyData es where
  data 'Action' LazyData
    = Details
    deriving (Generic, 'ViewAction')

  'update' Details = do
    LazyData taskId <- 'viewId'
    task <- pretendLoadTask taskId
    pure $ viewTaskDetails task
@
-}
class HasViewId m view where
  viewId :: m view


instance HasViewId (View ctx) ctx where
  viewId :: View ctx ctx
viewId = (ctx, ViewState ctx) -> ctx
forall a b. (a, b) -> a
fst ((ctx, ViewState ctx) -> ctx)
-> View ctx (ctx, ViewState ctx) -> View ctx ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> View ctx (ctx, ViewState ctx)
forall c. View c (c, ViewState c)
context
instance (ViewState view ~ st) => HasViewId (Eff (Reader view : State st : es)) view where
  viewId :: Eff (Reader view : State st : es) view
viewId = Eff (Reader view : State st : es) view
forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask


encodeViewId :: (ViewId id) => id -> Text
encodeViewId :: forall id. ViewId id => id -> Text
encodeViewId = Encoded -> Text
encodedToText (Encoded -> Text) -> (id -> Encoded) -> id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. id -> Encoded
forall a. ViewId a => a -> Encoded
toViewId


decodeViewId :: (ViewId id) => Text -> Maybe id
decodeViewId :: forall id. ViewId id => Text -> Maybe id
decodeViewId Text
t = do
  case Encoded -> Either String id
forall a. ViewId a => Encoded -> Either String a
parseViewId (Encoded -> Either String id)
-> Either String Encoded -> Either String id
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Either String Encoded
forall a. FromEncoded a => Text -> Either String a
decodeEither Text
t of
    Left String
_ -> Maybe id
forall a. Maybe a
Nothing
    Right id
a -> id -> Maybe id
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure id
a