{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Polysemy.JSONFileKVStore where import Control.Monad.Catch import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson import qualified Data.Map as Map import Data.Map (Map) import GHC.Generics import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.KVStore import Path import qualified UnliftIO.Path.Directory as U newtype JSONParseException = JSONParseException String deriving (Int -> JSONParseException -> ShowS [JSONParseException] -> ShowS JSONParseException -> String (Int -> JSONParseException -> ShowS) -> (JSONParseException -> String) -> ([JSONParseException] -> ShowS) -> Show JSONParseException forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [JSONParseException] -> ShowS $cshowList :: [JSONParseException] -> ShowS show :: JSONParseException -> String $cshow :: JSONParseException -> String showsPrec :: Int -> JSONParseException -> ShowS $cshowsPrec :: Int -> JSONParseException -> ShowS Show, JSONParseException -> JSONParseException -> Bool (JSONParseException -> JSONParseException -> Bool) -> (JSONParseException -> JSONParseException -> Bool) -> Eq JSONParseException forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: JSONParseException -> JSONParseException -> Bool $c/= :: JSONParseException -> JSONParseException -> Bool == :: JSONParseException -> JSONParseException -> Bool $c== :: JSONParseException -> JSONParseException -> Bool Eq, (forall x. JSONParseException -> Rep JSONParseException x) -> (forall x. Rep JSONParseException x -> JSONParseException) -> Generic JSONParseException forall x. Rep JSONParseException x -> JSONParseException forall x. JSONParseException -> Rep JSONParseException x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep JSONParseException x -> JSONParseException $cfrom :: forall x. JSONParseException -> Rep JSONParseException x Generic) instance Exception JSONParseException where displayException :: JSONParseException -> String displayException (JSONParseException String x) = String x eitherDecodeOrCreate :: (ToJSON a, FromJSON a, MonadIO m) => Path b File -> a -> m (Either String a) eitherDecodeOrCreate :: Path b File -> a -> m (Either String a) eitherDecodeOrCreate Path b File f a x = do m Bool -> m () -> m () forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM ((Bool -> Bool) -> m Bool -> m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Bool -> Bool not (m Bool -> m Bool) -> (Path b File -> m Bool) -> Path b File -> m Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Path b File -> m Bool forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool U.doesFileExist (Path b File -> m Bool) -> Path b File -> m Bool forall a b. (a -> b) -> a -> b $ Path b File f) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> a -> IO () forall a. ToJSON a => String -> a -> IO () encodeFile (Path b File -> String forall b t. Path b t -> String toFilePath Path b File f) a x IO (Either String a) -> m (Either String a) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either String a) -> m (Either String a)) -> IO (Either String a) -> m (Either String a) forall a b. (a -> b) -> a -> b $ String -> IO (Either String a) forall a. FromJSON a => String -> IO (Either String a) eitherDecodeFileStrict' (Path b File -> String forall b t. Path b t -> String toFilePath Path b File f) runKVStoreAsJSONFileStore :: (Members '[Embed IO, Error JSONParseException] r, FromJSONKey k, ToJSONKey k, FromJSON v, ToJSON v, Ord k) => Path b File -> Sem (KVStore k v ': r) a -> Sem r a runKVStoreAsJSONFileStore :: Path b File -> Sem (KVStore k v : r) a -> Sem r a runKVStoreAsJSONFileStore Path b File d = (forall x (m :: * -> *). KVStore k v m x -> Sem r x) -> Sem (KVStore k v : r) a -> Sem r a forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a. FirstOrder e "interpret" => (forall x (m :: * -> *). e m x -> Sem r x) -> Sem (e : r) a -> Sem r a interpret \case LookupKV k -> do Either String (Map k v) z <- Path b File -> Map k v -> Sem r (Either String (Map k v)) forall a (m :: * -> *) b. (ToJSON a, FromJSON a, MonadIO m) => Path b File -> a -> m (Either String a) eitherDecodeOrCreate Path b File d Map k v forall a. Monoid a => a mempty case Either String (Map k v) z of Left String x -> forall (r :: [(* -> *) -> * -> *]) a. MemberWithError (Error JSONParseException) r => JSONParseException -> Sem r a forall e (r :: [(* -> *) -> * -> *]) a. MemberWithError (Error e) r => e -> Sem r a throw @JSONParseException (JSONParseException -> Sem r x) -> JSONParseException -> Sem r x forall a b. (a -> b) -> a -> b $ String -> JSONParseException JSONParseException String x Right Map k v x -> Maybe v -> Sem r (Maybe v) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe v -> Sem r (Maybe v)) -> Maybe v -> Sem r (Maybe v) forall a b. (a -> b) -> a -> b $ k -> Map k v -> Maybe v forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup k k Map k v x UpdateKV k v -> do Either String (Map k v) z <- Path b File -> Map k v -> Sem r (Either String (Map k v)) forall a (m :: * -> *) b. (ToJSON a, FromJSON a, MonadIO m) => Path b File -> a -> m (Either String a) eitherDecodeOrCreate Path b File d Map k v forall a. Monoid a => a mempty case Either String (Map k v) z of Left String x -> JSONParseException -> Sem r x forall e (r :: [(* -> *) -> * -> *]) a. MemberWithError (Error e) r => e -> Sem r a throw (JSONParseException -> Sem r x) -> JSONParseException -> Sem r x forall a b. (a -> b) -> a -> b $ String -> JSONParseException JSONParseException String x Right (Map k v x :: Map k v) -> IO () -> Sem r () forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a. Member (Embed m) r => m a -> Sem r a embed (IO () -> Sem r ()) -> IO () -> Sem r () forall a b. (a -> b) -> a -> b $ String -> Map k v -> IO () forall a. ToJSON a => String -> a -> IO () encodeFile (Path b File -> String forall b t. Path b t -> String toFilePath Path b File d) ((Maybe v -> Maybe v) -> k -> Map k v -> Map k v forall k a. Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a Map.alter (Maybe v -> Maybe v -> Maybe v forall a b. a -> b -> a const Maybe v v) k k Map k v x)