{-# LANGUAGE OverloadedStrings #-}
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
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)
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')
)
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)
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)
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
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
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
register ::
(Monad m) =>
(ByteString -> Either ByteString a) ->
(a -> ByteString) ->
(ByteString -> a -> r) ->
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)
)
)
message ::
(Monad m) =>
(ByteString -> Either ByteString a) ->
(ByteString -> a -> r) ->
a ->
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
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)
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)