{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_HADDOCK hide, not-home #-}
module Web.Rep.Shared
( RepF (..),
Rep,
oneRep,
SharedRepF (..),
SharedRep,
runOnce,
zeroState,
register,
message,
genName,
genNamePre,
)
where
import Control.Applicative
import Control.Monad.State.Lazy
import Data.Biapplicative
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, pack)
import Lucid
import Optics.Core
import Optics.Zoom
data RepF r a = Rep
{ forall r a. RepF r a -> r
rep :: r,
forall r a.
RepF r a -> HashMap Text Text -> (HashMap Text Text, Either Text a)
make :: HashMap Text Text -> (HashMap Text Text, Either Text 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)
type Rep a = RepF (Html ()) a
instance (Semigroup r) => Semigroup (RepF r a) where
(Rep r
r0 HashMap Text Text -> (HashMap Text Text, Either Text a)
a0) <> :: RepF r a -> RepF r a -> RepF r a
<> (Rep r
r1 HashMap Text Text -> (HashMap Text Text, Either Text a)
a1) =
forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep
(r
r0 forall a. Semigroup a => a -> a -> a
<> r
r1)
(\HashMap Text Text
hm -> let (HashMap Text Text
hm', Either Text a
x') = HashMap Text Text -> (HashMap Text Text, Either Text a)
a0 HashMap Text Text
hm in let (HashMap Text Text
hm'', Either Text a
x'') = HashMap Text Text -> (HashMap Text Text, Either Text a)
a1 HashMap Text Text
hm' in (HashMap Text Text
hm'', Either Text a
x' forall a. Semigroup a => a -> a -> a
<> Either Text a
x''))
instance (Monoid a, Monoid r) => Monoid (RepF r a) where
mempty :: RepF r a
mempty = forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text 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 Text Text -> (HashMap Text Text, Either Text c)
a) = forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text 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 Text Text -> (HashMap Text Text, Either Text 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 Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep a
r (,forall a b. b -> Either a b
Right b
a)
(Rep a -> b
fr HashMap Text Text -> (HashMap Text Text, Either Text (c -> d))
fa) <<*>> :: forall a b c d. RepF (a -> b) (c -> d) -> RepF a c -> RepF b d
<<*>> (Rep a
r HashMap Text Text -> (HashMap Text Text, Either Text c)
a) =
forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep
(a -> b
fr a
r)
( \HashMap Text Text
hm ->
let (HashMap Text Text
hm', Either Text c
a') = HashMap Text Text -> (HashMap Text Text, Either Text c)
a HashMap Text Text
hm in let (HashMap Text Text
hm'', Either Text (c -> d)
fa') = HashMap Text Text -> (HashMap Text Text, Either Text (c -> d))
fa HashMap Text Text
hm' in (HashMap Text Text
hm'', Either Text (c -> d)
fa' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text 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 Text Text -> (HashMap Text Text, Either Text (a -> b))
fm <*> :: forall a b. RepF r (a -> b) -> RepF r a -> RepF r b
<*> Rep r
ah HashMap Text Text -> (HashMap Text Text, Either Text a)
am =
forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep
(r
fh forall a. Semigroup a => a -> a -> a
<> r
ah)
( \HashMap Text Text
hm ->
let (HashMap Text Text
hm', Either Text a
a') = HashMap Text Text -> (HashMap Text Text, Either Text a)
am HashMap Text Text
hm in let (HashMap Text Text
hm'', Either Text (a -> b)
fa') = HashMap Text Text -> (HashMap Text Text, Either Text (a -> b))
fm HashMap Text Text
hm' in (HashMap Text Text
hm'', Either Text (a -> b)
fa' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text a
a')
)
oneRep :: (Monad m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)
oneRep :: forall (m :: * -> *) a.
Monad m =>
Rep a
-> (Rep a -> HashMap Text Text -> m ())
-> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)
oneRep r :: Rep a
r@(Rep Html ()
_ HashMap Text Text -> (HashMap Text Text, Either Text a)
fa) Rep a -> HashMap Text Text -> m ()
action = do
HashMap Text Text
m <- forall s (m :: * -> *). MonadState s m => m s
get
let (HashMap Text Text
m', Either Text a
a) = HashMap Text Text -> (HashMap Text Text, Either Text a)
fa HashMap Text Text
m
forall s (m :: * -> *). MonadState s m => s -> m ()
put HashMap Text Text
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 Text Text -> m ()
action Rep a
r HashMap Text Text
m'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Text
m', Either Text a
a)
newtype SharedRepF m r a = SharedRep
{ forall (m :: * -> *) r a.
SharedRepF m r a -> StateT (Int, HashMap Text Text) m (RepF r a)
unshare :: StateT (Int, HashMap Text Text) 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)
type SharedRep m a = SharedRepF m (Html ()) 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 Text Text) m (RepF a c)
s) = forall (m :: * -> *) r a.
StateT (Int, HashMap Text Text) 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 Text Text) 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 Text Text) 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 Text Text) 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 Text Text) m (RepF a c)
a) = forall (m :: * -> *) r a.
StateT (Int, HashMap Text Text) 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 Text Text) m (RepF (a -> b) (c -> d))
f StateT (Int, HashMap Text Text) 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 Text Text) 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 Text Text) m (RepF r a)
a = forall (m :: * -> *) r a.
StateT (Int, HashMap Text Text) 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 Text Text) m (RepF r (a -> b))
f StateT (Int, HashMap Text Text) m (RepF r a)
a
genName :: (MonadState Int m) => m Text
genName :: forall (m :: * -> *). MonadState Int m => m Text
genName = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+ Int
1)
String -> Text
pack 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
genNamePre :: (MonadState Int m) => Text -> m Text
genNamePre :: forall (m :: * -> *). MonadState Int m => Text -> m Text
genNamePre Text
p = (Text
p forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadState Int m => m Text
genName
register ::
(Monad m) =>
(Text -> Either Text a) ->
(a -> Text) ->
(Text -> a -> r) ->
a ->
SharedRepF m r a
register :: forall (m :: * -> *) a r.
Monad m =>
(Text -> Either Text a)
-> (a -> Text) -> (Text -> a -> r) -> a -> SharedRepF m r a
register Text -> Either Text a
p a -> Text
pr Text -> a -> r
f a
a =
forall (m :: * -> *) r a.
StateT (Int, HashMap Text Text) m (RepF r a) -> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ do
Text
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 Text
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 Text
name (a -> Text
pr a
a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep
(Text -> a -> r
f Text
name a
a)
( \HashMap Text Text
s ->
( HashMap Text Text
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 Text
"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
. (\Text
x -> Text
name forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
x)) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
p)
(forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
name HashMap Text Text
s)
)
)
message ::
(Monad m) =>
(Text -> Either Text a) ->
(Text -> a -> r) ->
a ->
a ->
SharedRepF m r a
message :: forall (m :: * -> *) a r.
Monad m =>
(Text -> Either Text a)
-> (Text -> a -> r) -> a -> a -> SharedRepF m r a
message Text -> Either Text a
p Text -> a -> r
f a
a a
d =
forall (m :: * -> *) r a.
StateT (Int, HashMap Text Text) m (RepF r a) -> SharedRepF m r a
SharedRep forall a b. (a -> b) -> a -> b
$ do
Text
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 Text
genName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall r a.
r
-> (HashMap Text Text -> (HashMap Text Text, Either Text a))
-> RepF r a
Rep
(Text -> a -> r
f Text
name a
a)
( \HashMap Text Text
s ->
( forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete Text
name HashMap Text Text
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
. Text -> Either Text a
p) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
name HashMap Text Text
s)
)
)
runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
runSharedRep :: forall (m :: * -> *) r a.
SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
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 Text Text) m (RepF r a)
unshare SharedRepF m r a
s
zeroState ::
(Monad m) =>
SharedRep m a ->
m (Html (), (HashMap Text Text, Either Text a))
zeroState :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a -> m (Html (), (HashMap Text Text, Either Text a))
zeroState SharedRep m a
sr = do
(Rep Html ()
h HashMap Text Text -> (HashMap Text Text, Either Text a)
fa, (Int
_, HashMap Text Text
m)) <- forall (m :: * -> *) r a.
SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
runSharedRep SharedRep m a
sr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html ()
h, HashMap Text Text -> (HashMap Text Text, Either Text a)
fa HashMap Text Text
m)
runOnce ::
(Monad m) =>
SharedRep m a ->
(Html () -> HashMap Text Text -> m ()) ->
m (HashMap Text Text, Either Text a)
runOnce :: forall (m :: * -> *) a.
Monad m =>
SharedRep m a
-> (Html () -> HashMap Text Text -> m ())
-> m (HashMap Text Text, Either Text a)
runOnce SharedRep m a
sr Html () -> HashMap Text Text -> m ()
action = do
(Rep Html ()
h HashMap Text Text -> (HashMap Text Text, Either Text a)
fa, (Int
_, HashMap Text Text
m)) <- forall (m :: * -> *) r a.
SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
runSharedRep SharedRep m a
sr
Html () -> HashMap Text Text -> m ()
action Html ()
h HashMap Text Text
m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Text -> (HashMap Text Text, Either Text a)
fa HashMap Text Text
m)