Skip to content

Instantly share code, notes, and snippets.

@thomashoneyman
Created November 26, 2022 15:51
Show Gist options
  • Save thomashoneyman/a7984ac44b0d15f8d5aa61c873b64968 to your computer and use it in GitHub Desktop.
Save thomashoneyman/a7984ac44b0d15f8d5aa61c873b64968 to your computer and use it in GitHub Desktop.
Typed CACHE Effect
module Registry.Effect.Cache where
import Prelude
import Data.Argonaut.Core as Argonaut.Core
import Data.Argonaut.Parser as Argonaut.Parser
import Data.Codec.Argonaut (JsonCodec)
import Data.Codec.Argonaut as CA
import Data.Const (Const(..))
import Data.Either (hush)
import Data.Exists (Exists)
import Data.Exists as Exists
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Node.Path (FilePath)
import Run (AFF, Run)
import Run as Run
import Run.State (STATE)
import Run.State as Run.State
import Type.Proxy (Proxy(..))
import Type.Row (type (+))
class Functor2 (c :: Type -> Type -> Type) where
map2 :: forall a b z. (a -> b) -> c z a -> c z b
newtype Reply a b = Reply (Maybe a -> b)
instance Functor2 Reply where
map2 k (Reply f) = Reply (map k f)
newtype Ignore :: forall k. k -> Type -> Type
newtype Ignore a b = Ignore b
instance Functor2 Ignore where
map2 k (Ignore b) = Ignore (k b)
data Cache key a
= Get (key Reply a)
| Put (forall void. key Const void) a
| Delete (key Ignore a)
derive instance (Functor (k Reply), Functor (k Ignore)) => Functor (Cache k)
type CacheKey :: ((Type -> Type -> Type) -> Type -> Type) -> Type -> Type
type CacheKey k a = forall c b. c a b -> k c b
get :: forall k a. CacheKey k a -> Cache k (Maybe a)
get key = Get (key (Reply identity))
put :: forall k a. CacheKey k a -> a -> Cache k Unit
put key value = Put (key (Const value)) unit
delete :: forall k a. CacheKey k a -> Cache k Unit
delete key = Delete (key (Ignore unit))
type CACHE key r = (cache :: Cache key | r)
_cache = Proxy :: Proxy "cache"
type FileSystemKey a =
{ path :: FilePath
, codec :: JsonCodec a
}
type FileSystemKeyHandler key = forall b z. key z b -> FileSystem z b
data FileSystemBox :: (Type -> Type -> Type) -> Type -> Type -> Type
data FileSystemBox z b a = FileSystem (FileSystemKey a) (z a b)
type FileSystem z b = Exists (FileSystemBox z b)
handleCacheFileSystem
:: forall key a r
. FileSystemKeyHandler key
-> Cache key a
-> Run (AFF + r) a
handleCacheFileSystem handler = case _ of
Get key -> handler key # Exists.runExists \(FileSystem { path, codec } (Reply reply)) -> do
let decoded = hush <<< CA.decode codec =<< hush (Argonaut.Parser.jsonParser "")
pure (reply decoded)
Put key next -> handler key # Exists.runExists \(FileSystem { path, codec } (Const value)) -> do
let encoded = Argonaut.Core.stringify $ CA.encode codec value
pure next
Delete key -> handler key # Exists.runExists \(FileSystem { path, codec } (Ignore next)) -> do
pure next
----------
-- Example interpreter, using key
----------
data RegistryCache :: (Type -> Type -> Type) -> Type -> Type
data RegistryCache c a = ConfigKey Int (c Int a)
instance Functor2 c => Functor (RegistryCache c) where
map k = case _ of
ConfigKey int a -> ConfigKey int (map2 k a)
registryCacheKeyHandler :: FileSystemKeyHandler RegistryCache
registryCacheKeyHandler = case _ of
ConfigKey id next -> Exists.mkExists $ FileSystem { path: show id, codec: CA.int } next
getItem :: forall a r. CacheKey RegistryCache a -> Run (CACHE RegistryCache + r) (Maybe a)
getItem key = Run.lift _cache (get key)
putItem :: forall a r. CacheKey RegistryCache a -> a -> Run (CACHE RegistryCache + r) Unit
putItem key val = Run.lift _cache (put key val)
deleteItem :: forall a r. CacheKey RegistryCache a -> Run (CACHE RegistryCache + r) Unit
deleteItem key = Run.lift _cache (delete key)
program :: forall r. Run (CACHE RegistryCache + r) Unit
program = do
putItem (ConfigKey 1) 500
res <- getItem (ConfigKey 1)
case res of
Nothing -> pure unit
Just _ -> deleteItem (ConfigKey 1)
pure unit
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment