{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Shpadoinkle.Html.LocalStorage where
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.String
import Data.Text
import GHC.Generics
import GHCJS.DOM
import GHCJS.DOM.Types hiding (Text)
import GHCJS.DOM.Storage
import GHCJS.DOM.Window
import Text.Read
import UnliftIO
import UnliftIO.Concurrent (forkIO)
import Shpadoinkle (shouldUpdate)
newtype LocalStorageKey a = LocalStorageKey { unLocalStorageKey :: Text }
deriving (Semigroup, Monoid, IsString, Eq, Ord, Show, Read, Generic)
setStorage :: MonadJSM m => Show a => LocalStorageKey a -> a -> m ()
setStorage (LocalStorageKey k) m = do
w <- currentWindow
case w of
Just w' -> do
s <- getLocalStorage w'
setItem s k $ show m
return ()
Nothing -> return ()
getStorage :: MonadJSM m => Read a => LocalStorageKey a -> m (Maybe a)
getStorage (LocalStorageKey k) = runMaybeT $ do
w <- MaybeT $ currentWindow
s <- MaybeT $ Just <$> getLocalStorage w
MaybeT $ (>>= readMaybe) <$> getItem s k
saveOnChange :: MonadJSM m => Show a => Eq a
=> LocalStorageKey a -> TVar a -> m ()
saveOnChange k = liftJSM . shouldUpdate (const $ setStorage k) ()
manageLocalStorage
:: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
=> MonadJSM m
#endif
=> Show a
=> Read a
=> Eq a
=> LocalStorageKey a -> a -> m (TVar a)
manageLocalStorage k initial = do
model <- liftIO . newTVarIO . fromMaybe initial =<< getStorage k
void . forkIO $ saveOnChange k model
return model