{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.Lens
import Data.Generics.Labels ()
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import GHC.Show (show)
import Lucid
import NumHask.Prelude hiding (show)
data RepF r a
= Rep
{ rep :: r,
make :: HashMap Text Text -> (HashMap Text Text, Either Text a)
}
deriving (Functor)
type Rep a = RepF (Html ()) a
instance (Semigroup r) => Semigroup (RepF r a) where
(Rep r0 a0) <> (Rep r1 a1) =
Rep
(r0 <> r1)
(\hm -> let (hm', x') = a0 hm in let (hm'', x'') = a1 hm' in (hm'', x' <> x''))
instance (Monoid a, Monoid r) => Monoid (RepF r a) where
mempty = Rep mempty (,Right mempty)
mappend = (<>)
instance Bifunctor RepF where
bimap f g (Rep r a) = Rep (f r) (second (fmap g) . a)
instance Biapplicative RepF where
bipure r a = Rep r (,Right a)
(Rep fr fa) <<*>> (Rep r a) =
Rep
(fr r)
( \hm ->
let (hm', a') = a hm in let (hm'', fa') = fa hm' in (hm'', fa' <*> a')
)
instance (Monoid r) => Applicative (RepF r) where
pure = bipure mempty
Rep fh fm <*> Rep ah am =
Rep
(fh <> ah)
( \hm ->
let (hm', a') = am hm in let (hm'', fa') = fm hm' in (hm'', fa' <*> a')
)
oneRep :: (Monad m, MonadIO m) => Rep a -> (Rep a -> HashMap Text Text -> m ()) -> StateT (HashMap Text Text) m (HashMap Text Text, Either Text a)
oneRep r@(Rep _ fa) action = do
m <- get
let (m', a) = fa m
put m'
lift $ action r m'
pure (m', a)
newtype SharedRepF m r a
= SharedRep
{ unshare :: StateT (Int, HashMap Text Text) m (RepF r a)
}
deriving (Functor)
type SharedRep m a = SharedRepF m (Html ()) a
instance (Functor m) => Bifunctor (SharedRepF m) where
bimap f g (SharedRep s) = SharedRep $ fmap (bimap f g) s
instance (Monad m) => Biapplicative (SharedRepF m) where
bipure r a = SharedRep $ pure $ bipure r a
(SharedRep f) <<*>> (SharedRep a) = SharedRep $ liftA2 (<<*>>) f a
instance (Monad m, Monoid r) => Applicative (SharedRepF m r) where
pure = bipure mempty
SharedRep f <*> SharedRep a = SharedRep $ liftA2 (<*>) f a
genName :: (MonadState Int m) => m Text
genName = do
modify (+ 1)
pack . show <$> get
genNamePre :: (MonadState Int m) => Text -> m Text
genNamePre p = (p <>) <$> genName
register ::
(Monad m) =>
(Text -> Either Text a) ->
(a -> Text) ->
(Text -> a -> r) ->
a ->
SharedRepF m r a
register p pr f a =
SharedRep $ do
name <- zoom _1 genName
zoom _2 (modify (HashMap.insert name (pr a)))
pure $
Rep
(f name a)
( \s ->
( s,
join
$ maybe (Left "lookup failed") Right
$ either (Left . (\x -> name <> ": " <> x)) Right . p <$>
HashMap.lookup name s
)
)
message ::
(Monad m) =>
(Text -> Either Text a) ->
(Text -> a -> r) ->
a ->
a ->
SharedRepF m r a
message p f a d =
SharedRep $ do
name <- zoom _1 genName
pure $
Rep
(f name a)
( \s ->
( HashMap.delete name s,
join
$ maybe (Right $ Right d) Right
$ p <$>
HashMap.lookup name s
)
)
runSharedRep :: SharedRepF m r a -> m (RepF r a, (Int, HashMap Text Text))
runSharedRep s = flip runStateT (0, HashMap.empty) $ unshare s
zeroState ::
(Monad m) =>
SharedRep m a ->
m (Html (), (HashMap Text Text, Either Text a))
zeroState sr = do
(Rep h fa, (_, m)) <- runSharedRep sr
pure (h, fa m)
runOnce ::
(Monad m) =>
SharedRep m a ->
(Html () -> HashMap Text Text -> m ()) ->
m (HashMap Text Text, Either Text a)
runOnce sr action = do
(Rep h fa, (_, m)) <- runSharedRep sr
action h m
pure (fa m)