{-# LANGUAGE OverloadedStrings #-}

-- | A shared-element representation of web page communication.
module Web.Rep.Shared
  ( RepF (..),
    Rep,
    oneRep,
    SharedRepF (..),
    SharedRep,
    runOnce,
    zeroState,
    register,
    message,
    genName,
    genNamePre,
  )
where

import Control.Applicative
import Control.Monad
import Control.Monad.State.Lazy
import Data.Biapplicative
import Data.ByteString (ByteString)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import MarkupParse
import Optics.Core
import Optics.Zoom

-- |
-- Information contained in a web page can usually be considered to be isomorphic to a map of named values - a 'HashMap'. This is especially true when considering a differential of information contained in a web page. Looking at a page from the outside, it often looks like a streaming differential of a hashmap.
--
-- RepF consists of an underlying value being represented, and, given a hashmap state, a way to produce a representation of the underlying value (or error), in another domain, together with the potential to alter the hashmap state.
data RepF r a = Rep
  { forall r a. RepF r a -> r
rep :: r,
    forall r a.
RepF r a
-> HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
make :: HashMap ByteString ByteString -> (HashMap ByteString ByteString, Either ByteString a)
  }
  deriving (forall a b. a -> RepF r b -> RepF r a
forall a b. (a -> b) -> RepF r a -> RepF r b
forall r a b. a -> RepF r b -> RepF r a
forall r a b. (a -> b) -> RepF r a -> RepF r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RepF r b -> RepF r a
$c<$ :: forall r a b. a -> RepF r b -> RepF r a
fmap :: forall a b. (a -> b) -> RepF r a -> RepF r b
$cfmap :: forall r a b. (a -> b) -> RepF r a -> RepF r b
Functor)

-- | the common usage, where the representation domain is Html
type Rep a = RepF Markup a

instance (Semigroup r) => Semigroup (RepF r a) where
  (Rep r
r0 HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
a0) <> :: RepF r a -> RepF r a -> RepF r a
<> (Rep r
r1 HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
a1) =
    forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep
      (r
r0 forall a. Semigroup a => a -> a -> a
<> r
r1)
      (\HashMap ByteString ByteString
hm -> let (HashMap ByteString ByteString
hm', Either ByteString a
x') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
a0 HashMap ByteString ByteString
hm in let (HashMap ByteString ByteString
hm'', Either ByteString a
x'') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
a1 HashMap ByteString ByteString
hm' in (HashMap ByteString ByteString
hm'', Either ByteString a
x' forall a. Semigroup a => a -> a -> a
<> Either ByteString a
x''))

instance (Monoid a, Monoid r) => Monoid (RepF r a) where
  mempty :: RepF r a
  mempty :: RepF r a
mempty = forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep forall a. Monoid a => a
mempty (,forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty)

  mappend :: RepF r a -> RepF r a -> RepF r a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Bifunctor RepF where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> RepF a c -> RepF b d
bimap a -> b
f c -> d
g (Rep a
r HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString c)
a) = forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep (a -> b
f a
r) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString c)
a)

instance Biapplicative RepF where
  bipure :: forall a b. a -> b -> RepF a b
bipure a
r b
a = forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep a
r (,forall a b. b -> Either a b
Right b
a)

  (Rep a -> b
fr HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString (c -> d))
fa) <<*>> :: forall a b c d. RepF (a -> b) (c -> d) -> RepF a c -> RepF b d
<<*>> (Rep a
r HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString c)
a) =
    forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep
      (a -> b
fr a
r)
      ( \HashMap ByteString ByteString
hm ->
          let (HashMap ByteString ByteString
hm', Either ByteString c
a') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString c)
a HashMap ByteString ByteString
hm in let (HashMap ByteString ByteString
hm'', Either ByteString (c -> d)
fa') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString (c -> d))
fa HashMap ByteString ByteString
hm' in (HashMap ByteString ByteString
hm'', Either ByteString (c -> d)
fa' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either ByteString c
a')
      )

instance (Monoid r) => Applicative (RepF r) where
  pure :: forall a. a -> RepF r a
pure = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure forall a. Monoid a => a
mempty

  Rep r
fh HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString (a -> b))
fm <*> :: forall a b. RepF r (a -> b) -> RepF r a -> RepF r b
<*> Rep r
ah HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
am =
    forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep
      (r
fh forall a. Semigroup a => a -> a -> a
<> r
ah)
      ( \HashMap ByteString ByteString
hm ->
          let (HashMap ByteString ByteString
hm', Either ByteString a
a') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
am HashMap ByteString ByteString
hm in let (HashMap ByteString ByteString
hm'', Either ByteString (a -> b)
fa') = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString (a -> b))
fm HashMap ByteString ByteString
hm' in (HashMap ByteString ByteString
hm'', Either ByteString (a -> b)
fa' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either ByteString a
a')
      )

-- | stateful result of one step, given a 'Rep', and a monadic action.
-- Useful for testing and for initialising a page.
oneRep :: (Monad m) => Rep a -> (Rep a -> HashMap ByteString ByteString -> m ()) -> StateT (HashMap ByteString ByteString) m (HashMap ByteString ByteString, Either ByteString a)
oneRep :: forall (m :: * -> *) a.
Monad m =>
Rep a
-> (Rep a -> HashMap ByteString ByteString -> m ())
-> StateT
     (HashMap ByteString ByteString)
     m
     (HashMap ByteString ByteString, Either ByteString a)
oneRep r :: Rep a
r@(Rep Markup
_ HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa) Rep a -> HashMap ByteString ByteString -> m ()
action = do
  HashMap ByteString ByteString
m <- forall s (m :: * -> *). MonadState s m => m s
get
  let (HashMap ByteString ByteString
m', Either ByteString a
a) = HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa HashMap ByteString ByteString
m
  forall s (m :: * -> *). MonadState s m => s -> m ()
put HashMap ByteString ByteString
m'
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Rep a -> HashMap ByteString ByteString -> m ()
action Rep a
r HashMap ByteString ByteString
m'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap ByteString ByteString
m', Either ByteString a
a)

-- |
-- Driven by the architecture of the DOM, web page components are compositional, and tree-like, where components are often composed of other components, and values are thus shared across components.
--
-- This is sometimes referred to as "observable sharing". See <http://hackage.haskell.org/package/data-reify data-reify> as another library that reifies this (pun intended), and provided the initial inspiration for this implementation.
--
-- unshare should only be run once, which is a terrible flaw that might be fixed by linear types.
newtype SharedRepF m r a = SharedRep
  { forall (m :: * -> *) r a.
SharedRepF m r a
-> StateT (Int, HashMap ByteString ByteString) m (RepF r a)
unshare :: StateT (Int, HashMap ByteString ByteString) m (RepF r a)
  }
  deriving (forall a b. a -> SharedRepF m r b -> SharedRepF m r a
forall a b. (a -> b) -> SharedRepF m r a -> SharedRepF m r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) r a b.
Functor m =>
a -> SharedRepF m r b -> SharedRepF m r a
forall (m :: * -> *) r a b.
Functor m =>
(a -> b) -> SharedRepF m r a -> SharedRepF m r b
<$ :: forall a b. a -> SharedRepF m r b -> SharedRepF m r a
$c<$ :: forall (m :: * -> *) r a b.
Functor m =>
a -> SharedRepF m r b -> SharedRepF m r a
fmap :: forall a b. (a -> b) -> SharedRepF m r a -> SharedRepF m r b
$cfmap :: forall (m :: * -> *) r a b.
Functor m =>
(a -> b) -> SharedRepF m r a -> SharedRepF m r b
Functor)

-- | default representation type of 'Html' ()
type SharedRep m a = SharedRepF m Markup a

instance (Functor m) => Bifunctor (SharedRepF m) where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> SharedRepF m a c -> SharedRepF m b d
bimap a -> b
f c -> d
g (SharedRep StateT (Int, HashMap ByteString ByteString) m (RepF a c)
s) = forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) StateT (Int, HashMap ByteString ByteString) m (RepF a c)
s

instance (Monad m) => Biapplicative (SharedRepF m) where
  bipure :: forall a b. a -> b -> SharedRepF m a b
bipure a
r b
a = forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure a
r b
a

  (SharedRep StateT
  (Int, HashMap ByteString ByteString) m (RepF (a -> b) (c -> d))
f) <<*>> :: forall a b c d.
SharedRepF m (a -> b) (c -> d)
-> SharedRepF m a c -> SharedRepF m b d
<<*>> (SharedRep StateT (Int, HashMap ByteString ByteString) m (RepF a c)
a) = forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
(<<*>>) StateT
  (Int, HashMap ByteString ByteString) m (RepF (a -> b) (c -> d))
f StateT (Int, HashMap ByteString ByteString) m (RepF a c)
a

instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where
  pure :: forall a. a -> SharedRepF m r a
pure = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure forall a. Monoid a => a
mempty

  SharedRep StateT (Int, HashMap ByteString ByteString) m (RepF r (a -> b))
f <*> :: forall a b.
SharedRepF m r (a -> b) -> SharedRepF m r a -> SharedRepF m r b
<*> SharedRep StateT (Int, HashMap ByteString ByteString) m (RepF r a)
a = forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) StateT (Int, HashMap ByteString ByteString) m (RepF r (a -> b))
f StateT (Int, HashMap ByteString ByteString) m (RepF r a)
a

-- | name supply for elements of a 'SharedRep'
genName :: (MonadState Int m) => m ByteString
genName :: forall (m :: * -> *). MonadState Int m => m ByteString
genName = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+ Int
1)
  String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get

-- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help
genNamePre :: (MonadState Int m) => ByteString -> m ByteString
genNamePre :: forall (m :: * -> *).
MonadState Int m =>
ByteString -> m ByteString
genNamePre ByteString
p = (ByteString
p <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState Int m => m ByteString
genName

-- | Create a sharedRep
register ::
  (Monad m) =>
  -- | Parser
  (ByteString -> Either ByteString a) ->
  -- | Printer
  (a -> ByteString) ->
  -- | create initial object from name and initial value
  (ByteString -> a -> r) ->
  -- | initial value
  a ->
  SharedRepF m r a
register :: forall (m :: * -> *) a r.
Monad m =>
(ByteString -> Either ByteString a)
-> (a -> ByteString)
-> (ByteString -> a -> r)
-> a
-> SharedRepF m r a
register ByteString -> Either ByteString a
p a -> ByteString
pr ByteString -> a -> r
f a
a =
  forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ do
    ByteString
name <- forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 forall (m :: * -> *). MonadState Int m => m ByteString
genName
    forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert ByteString
name (a -> ByteString
pr a
a)))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep
        (ByteString -> a -> r
f ByteString
name a
a)
        ( \HashMap ByteString ByteString
s ->
            ( HashMap ByteString ByteString
s,
              forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  (forall a b. a -> Either a b
Left ByteString
"lookup failed")
                  (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ByteString
x -> ByteString
name forall a. Semigroup a => a -> a -> a
<> ByteString
": " forall a. Semigroup a => a -> a -> a
<> ByteString
x)) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString a
p)
                  (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
name HashMap ByteString ByteString
s)
            )
        )

-- | Like 'register', but does not put a value into the HashMap on instantiation, consumes the value when found in the HashMap, and substitutes a default on lookup failure
message ::
  (Monad m) =>
  -- | Parser
  (ByteString -> Either ByteString a) ->
  -- | create initial object from name and initial value
  (ByteString -> a -> r) ->
  -- | initial value
  a ->
  -- | default value
  a ->
  SharedRepF m r a
message :: forall (m :: * -> *) a r.
Monad m =>
(ByteString -> Either ByteString a)
-> (ByteString -> a -> r) -> a -> a -> SharedRepF m r a
message ByteString -> Either ByteString a
p ByteString -> a -> r
f a
a a
d =
  forall (m :: * -> *) r a.
StateT (Int, HashMap ByteString ByteString) m (RepF r a)
-> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ do
    ByteString
n <- forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom forall s t a b. Field1 s t a b => Lens s t a b
_1 forall (m :: * -> *). MonadState Int m => m ByteString
genName
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall r a.
r
-> (HashMap ByteString ByteString
    -> (HashMap ByteString ByteString, Either ByteString a))
-> RepF r a
Rep
        (ByteString -> a -> r
f ByteString
n a
a)
        ( \HashMap ByteString ByteString
s ->
            ( forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete ByteString
n HashMap ByteString ByteString
s,
              forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
d) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString a
p) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
n HashMap ByteString ByteString
s)
            )
        )

runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap ByteString ByteString))
runSharedRep :: forall (m :: * -> *) r a.
SharedRepF m r a
-> m (RepF r a, (Int, HashMap ByteString ByteString))
runSharedRep SharedRepF m r a
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Int
0, forall k v. HashMap k v
HashMap.empty) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a.
SharedRepF m r a
-> StateT (Int, HashMap ByteString ByteString) m (RepF r a)
unshare SharedRepF m r a
s

-- | compute the initial state of a SharedRep (testing)
zeroState ::
  (Monad m) =>
  SharedRep m a ->
  m (Markup, (HashMap ByteString ByteString, Either ByteString a))
zeroState :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> m (Markup, (HashMap ByteString ByteString, Either ByteString a))
zeroState SharedRep m a
sr = do
  (Rep Markup
h HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa, (Int
_, HashMap ByteString ByteString
m)) <- forall (m :: * -> *) r a.
SharedRepF m r a
-> m (RepF r a, (Int, HashMap ByteString ByteString))
runSharedRep SharedRep m a
sr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Markup
h, HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa HashMap ByteString ByteString
m)

-- | Compute the initial state of a SharedRep and then run an action once (see tests).
runOnce ::
  (Monad m) =>
  SharedRep m a ->
  (Markup -> HashMap ByteString ByteString -> m ()) ->
  m (HashMap ByteString ByteString, Either ByteString a)
runOnce :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> (Markup -> HashMap ByteString ByteString -> m ())
-> m (HashMap ByteString ByteString, Either ByteString a)
runOnce SharedRep m a
sr Markup -> HashMap ByteString ByteString -> m ()
action = do
  (Rep Markup
h HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa, (Int
_, HashMap ByteString ByteString
m)) <- forall (m :: * -> *) r a.
SharedRepF m r a
-> m (RepF r a, (Int, HashMap ByteString ByteString))
runSharedRep SharedRep m a
sr
  Markup -> HashMap ByteString ByteString -> m ()
action Markup
h HashMap ByteString ByteString
m
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap ByteString ByteString
-> (HashMap ByteString ByteString, Either ByteString a)
fa HashMap ByteString ByteString
m)