------------------------------------------------------------------------
-- |
-- Module      :  ALife.Creatur.Persistent
-- Copyright   :  (c) 2012-2021 Amy de Buitléir
-- License     :  BSD-style
-- Maintainer  :  amy@nualeargais.ie
-- Stability   :  experimental
-- Portability :  portable
--
-- A state which persists between runs.
--
------------------------------------------------------------------------
module ALife.Creatur.Persistent
  (
    Persistent,
    mkPersistent,
    getPS,
    putPS,
    modifyPS,
    runPS
  ) where

import ALife.Creatur.Util (modifyLift)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, get, gets, modify)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import System.FilePath (dropFileName)
import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))
import Text.Read (readEither)

data Persistent a = Persistent {
    Persistent a -> Bool
psInitialised :: Bool,
    Persistent a -> a
psValue :: a,
    Persistent a -> a
psDefaultValue :: a,
    Persistent a -> FilePath
psFilename :: FilePath
  } deriving (Int -> Persistent a -> ShowS
[Persistent a] -> ShowS
Persistent a -> FilePath
(Int -> Persistent a -> ShowS)
-> (Persistent a -> FilePath)
-> ([Persistent a] -> ShowS)
-> Show (Persistent a)
forall a. Show a => Int -> Persistent a -> ShowS
forall a. Show a => [Persistent a] -> ShowS
forall a. Show a => Persistent a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Persistent a] -> ShowS
$cshowList :: forall a. Show a => [Persistent a] -> ShowS
show :: Persistent a -> FilePath
$cshow :: forall a. Show a => Persistent a -> FilePath
showsPrec :: Int -> Persistent a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Persistent a -> ShowS
Show, ReadPrec [Persistent a]
ReadPrec (Persistent a)
Int -> ReadS (Persistent a)
ReadS [Persistent a]
(Int -> ReadS (Persistent a))
-> ReadS [Persistent a]
-> ReadPrec (Persistent a)
-> ReadPrec [Persistent a]
-> Read (Persistent a)
forall a. Read a => ReadPrec [Persistent a]
forall a. Read a => ReadPrec (Persistent a)
forall a. Read a => Int -> ReadS (Persistent a)
forall a. Read a => ReadS [Persistent a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Persistent a]
$creadListPrec :: forall a. Read a => ReadPrec [Persistent a]
readPrec :: ReadPrec (Persistent a)
$creadPrec :: forall a. Read a => ReadPrec (Persistent a)
readList :: ReadS [Persistent a]
$creadList :: forall a. Read a => ReadS [Persistent a]
readsPrec :: Int -> ReadS (Persistent a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Persistent a)
Read, Persistent a -> Persistent a -> Bool
(Persistent a -> Persistent a -> Bool)
-> (Persistent a -> Persistent a -> Bool) -> Eq (Persistent a)
forall a. Eq a => Persistent a -> Persistent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Persistent a -> Persistent a -> Bool
$c/= :: forall a. Eq a => Persistent a -> Persistent a -> Bool
== :: Persistent a -> Persistent a -> Bool
$c== :: forall a. Eq a => Persistent a -> Persistent a -> Bool
Eq)

-- | Creates a counter that will store its value in the specified file.
mkPersistent :: a -> FilePath -> Persistent a
mkPersistent :: a -> FilePath -> Persistent a
mkPersistent a
s = Bool -> a -> a -> FilePath -> Persistent a
forall a. Bool -> a -> a -> FilePath -> Persistent a
Persistent Bool
False a
s a
s

getPS :: Read a => StateT (Persistent a) IO a
getPS :: StateT (Persistent a) IO a
getPS = StateT (Persistent a) IO ()
forall a. Read a => StateT (Persistent a) IO ()
initIfNeeded StateT (Persistent a) IO ()
-> StateT (Persistent a) IO a -> StateT (Persistent a) IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Persistent a -> a) -> StateT (Persistent a) IO a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Persistent a -> a
forall a. Persistent a -> a
psValue

putPS :: (Show a, Read a) => a -> StateT (Persistent a) IO ()
putPS :: a -> StateT (Persistent a) IO ()
putPS a
s = do
  StateT (Persistent a) IO ()
forall a. Read a => StateT (Persistent a) IO ()
initIfNeeded
  (Persistent a -> Persistent a) -> StateT (Persistent a) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Persistent a
p -> Persistent a
p { psValue :: a
psValue=a
s })
  Persistent a
p' <- StateT (Persistent a) IO (Persistent a)
forall s (m :: * -> *). MonadState s m => m s
get
  IO () -> StateT (Persistent a) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Persistent a) IO ())
-> IO () -> StateT (Persistent a) IO ()
forall a b. (a -> b) -> a -> b
$ Persistent a -> IO ()
forall a. Show a => Persistent a -> IO ()
store Persistent a
p'

modifyPS :: (Show a, Read a) => (a -> a) -> StateT (Persistent a) IO ()
modifyPS :: (a -> a) -> StateT (Persistent a) IO ()
modifyPS a -> a
f = do
  a
p <- StateT (Persistent a) IO a
forall a. Read a => StateT (Persistent a) IO a
getPS
  a -> StateT (Persistent a) IO ()
forall a. (Show a, Read a) => a -> StateT (Persistent a) IO ()
putPS (a -> StateT (Persistent a) IO ())
-> a -> StateT (Persistent a) IO ()
forall a b. (a -> b) -> a -> b
$ a -> a
f a
p

runPS :: Read a => (a -> b) -> StateT (Persistent a) IO b
runPS :: (a -> b) -> StateT (Persistent a) IO b
runPS a -> b
f = do
  a
p <- StateT (Persistent a) IO a
forall a. Read a => StateT (Persistent a) IO a
getPS
  b -> StateT (Persistent a) IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> StateT (Persistent a) IO b)
-> b -> StateT (Persistent a) IO b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
p

store :: Show a => Persistent a -> IO ()
store :: Persistent a -> IO ()
store Persistent a
p = do
  let f :: FilePath
f = Persistent a -> FilePath
forall a. Persistent a -> FilePath
psFilename Persistent a
p
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
dropFileName FilePath
f
  FilePath -> FilePath -> IO ()
writeFile FilePath
f (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show (Persistent a -> a
forall a. Persistent a -> a
psValue Persistent a
p)

initIfNeeded :: Read a => StateT (Persistent a) IO ()
initIfNeeded :: StateT (Persistent a) IO ()
initIfNeeded = do
  Bool
isInitialised <- (Persistent a -> Bool) -> StateT (Persistent a) IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Persistent a -> Bool
forall a. Persistent a -> Bool
psInitialised
  Bool -> StateT (Persistent a) IO () -> StateT (Persistent a) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInitialised (StateT (Persistent a) IO () -> StateT (Persistent a) IO ())
-> StateT (Persistent a) IO () -> StateT (Persistent a) IO ()
forall a b. (a -> b) -> a -> b
$ (Persistent a -> IO (Persistent a)) -> StateT (Persistent a) IO ()
forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyLift Persistent a -> IO (Persistent a)
forall a. Read a => Persistent a -> IO (Persistent a)
initialise

initialise :: Read a => Persistent a -> IO (Persistent a)
initialise :: Persistent a -> IO (Persistent a)
initialise Persistent a
p = do
  let f :: FilePath
f = Persistent a -> FilePath
forall a. Persistent a -> FilePath
psFilename Persistent a
p
  Bool
fExists <- FilePath -> IO Bool
doesFileExist FilePath
f
  if Bool
fExists
    then do
      Either FilePath a
x <- FilePath
-> IOMode
-> (Handle -> IO (Either FilePath a))
-> IO (Either FilePath a)
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
f IOMode
ReadMode Handle -> IO (Either FilePath a)
forall a. Read a => Handle -> IO (Either FilePath a)
readValue -- closes file ASAP
      case Either FilePath a
x of
        Left FilePath
msg -> FilePath -> IO (Persistent a)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Persistent a)) -> FilePath -> IO (Persistent a)
forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to read value from " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
msg
        Right a
c  -> Persistent a -> IO (Persistent a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Persistent a -> IO (Persistent a))
-> Persistent a -> IO (Persistent a)
forall a b. (a -> b) -> a -> b
$ Persistent a
p { psInitialised :: Bool
psInitialised=Bool
True, psValue :: a
psValue=a
c }
    else do
      Persistent a -> IO (Persistent a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Persistent a -> IO (Persistent a))
-> Persistent a -> IO (Persistent a)
forall a b. (a -> b) -> a -> b
$ Persistent a
p { psInitialised :: Bool
psInitialised=Bool
True, psValue :: a
psValue=Persistent a -> a
forall a. Persistent a -> a
psDefaultValue Persistent a
p }

readValue :: Read a => Handle -> IO (Either String a)
readValue :: Handle -> IO (Either FilePath a)
readValue Handle
h = do
  FilePath
s <- Handle -> IO FilePath
hGetContents Handle
h
  let x :: Either FilePath a
x = FilePath -> Either FilePath a
forall a. Read a => FilePath -> Either FilePath a
readEither FilePath
s
  case Either FilePath a
x of
    Left FilePath
msg -> Either FilePath a -> IO (Either FilePath a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath a -> IO (Either FilePath a))
-> Either FilePath a -> IO (Either FilePath a)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath
msg FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\"" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
s FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\"")
    Right a
c  -> Either FilePath a -> IO (Either FilePath a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath a -> IO (Either FilePath a))
-> Either FilePath a -> IO (Either FilePath a)
forall a b. (a -> b) -> a -> b
$ a -> Either FilePath a
forall a b. b -> Either a b
Right a
c