{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.View.Types where

import Data.Aeson (FromJSON, ToJSON)
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
import Web.Hyperbole.View.ViewId


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

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

@
#EMBED Example.Docs.BasicPage helloWorld
@
-}

{- | '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 <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    pure $ fmap f 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
    ha <- Eff '[Reader (ctx, ViewState ctx)] (Html a)
va
    hb <- vb
    pure $ liftA2 abc ha 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
    ha <- Eff '[Reader (ctx, ViewState ctx)] (Html a)
va
    hb <- vb
    pure $ ha *> 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
    ha <- Eff '[Reader (ctx, ViewState ctx)] (Html a)
ea
    let View eb = famb ha.value
    (ha >>) <$> 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, ToJSON a, FromJSON 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 <- forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @(c, ViewState c)
  pure $ pure 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
  st <- View c (ViewState c)
forall c. View c (ViewState c)
viewState
  c <- viewId
  runViewContext (f c) st 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
    h <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    pure $ modAttributes f 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
    h <- Eff '[Reader (c, ViewState c)] (Html a)
eff
    pure $ modCSS f h


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

@
#EMBED Example.Concurrency.LazyLoading data LazyData

#EMBED Example.Concurrency.LazyLoading instance (Debug :> es, GenRandom :> es) => HyperView LazyData es where
@
-}

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