module Simulation.Aivika.Experiment.Base.ExperimentWriter
(ExperimentWriter,
runExperimentWriter,
ExperimentFilePath(..),
experimentFilePath,
resolveFilePath,
expandFilePath,
mapFilePath) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State
import Control.Concurrent.MVar
import Control.Exception
import qualified Data.Map as M
import qualified Data.Set as S
import System.Directory
import System.FilePath
import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Experiment.Utils (replace)
data ExperimentFilePath = WritableFilePath FilePath
| UniqueFilePath FilePath
experimentFilePath :: ExperimentFilePath
experimentFilePath :: ExperimentFilePath
experimentFilePath = FilePath -> ExperimentFilePath
UniqueFilePath FilePath
"experiment"
resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath
resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath
resolveFilePath FilePath
dir (WritableFilePath FilePath
path) =
FilePath -> ExperimentWriter FilePath
forall a. a -> ExperimentWriter a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ExperimentWriter FilePath)
-> FilePath -> ExperimentWriter FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
path
resolveFilePath FilePath
dir (UniqueFilePath FilePath
path) =
(MVar (Set FilePath) -> IO FilePath) -> ExperimentWriter FilePath
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO FilePath) -> ExperimentWriter FilePath)
-> (MVar (Set FilePath) -> IO FilePath)
-> ExperimentWriter FilePath
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
let (FilePath
name, FilePath
ext) = FilePath -> (FilePath, FilePath)
splitExtension FilePath
path
loop :: FilePath -> t -> IO FilePath
loop FilePath
y t
i =
do let n :: FilePath
n = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
addExtension FilePath
y FilePath
ext
y' :: FilePath
y' = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ t -> FilePath
forall a. Show a => a -> FilePath
show t
i FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
Bool
f1 <- FilePath -> IO Bool
doesFileExist FilePath
n
Bool
f2 <- FilePath -> IO Bool
doesDirectoryExist FilePath
n
if Bool
f1 Bool -> Bool -> Bool
|| Bool
f2
then FilePath -> t -> IO FilePath
loop FilePath
y' (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)
else do Maybe FilePath
n' <- IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> IO (Maybe FilePath))
-> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
MVar (Set FilePath)
-> (Set FilePath -> IO (Set FilePath, Maybe FilePath))
-> IO (Maybe FilePath)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Set FilePath)
r ((Set FilePath -> IO (Set FilePath, Maybe FilePath))
-> IO (Maybe FilePath))
-> (Set FilePath -> IO (Set FilePath, Maybe FilePath))
-> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ \Set FilePath
s ->
if FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member FilePath
n Set FilePath
s
then (Set FilePath, Maybe FilePath) -> IO (Set FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set FilePath
s, Maybe FilePath
forall a. Maybe a
Nothing)
else (Set FilePath, Maybe FilePath) -> IO (Set FilePath, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
n Set FilePath
s, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
n)
case Maybe FilePath
n' of
Maybe FilePath
Nothing -> FilePath -> t -> IO FilePath
loop FilePath
y' (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)
Just FilePath
n' -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
n'
in FilePath -> Integer -> IO FilePath
forall {t}. (Num t, Show t) => FilePath -> t -> IO FilePath
loop FilePath
name Integer
2
expandFilePath :: ExperimentFilePath -> M.Map String String -> ExperimentFilePath
expandFilePath :: ExperimentFilePath -> Map FilePath FilePath -> ExperimentFilePath
expandFilePath (WritableFilePath FilePath
path) Map FilePath FilePath
map = FilePath -> ExperimentFilePath
WritableFilePath (FilePath -> Map FilePath FilePath -> FilePath
expandTemplates FilePath
path Map FilePath FilePath
map)
expandFilePath (UniqueFilePath FilePath
path) Map FilePath FilePath
map = FilePath -> ExperimentFilePath
UniqueFilePath (FilePath -> Map FilePath FilePath -> FilePath
expandTemplates FilePath
path Map FilePath FilePath
map)
expandTemplates :: String -> M.Map String String -> String
expandTemplates :: FilePath -> Map FilePath FilePath -> FilePath
expandTemplates FilePath
name Map FilePath FilePath
map = FilePath
name' where
((), FilePath
name') = (State FilePath () -> FilePath -> ((), FilePath))
-> FilePath -> State FilePath () -> ((), FilePath)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State FilePath () -> FilePath -> ((), FilePath)
forall s a. State s a -> s -> (a, s)
runState FilePath
name (State FilePath () -> ((), FilePath))
-> State FilePath () -> ((), FilePath)
forall a b. (a -> b) -> a -> b
$
[(FilePath, FilePath)]
-> ((FilePath, FilePath) -> State FilePath ()) -> State FilePath ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
M.assocs Map FilePath FilePath
map) (((FilePath, FilePath) -> State FilePath ()) -> State FilePath ())
-> ((FilePath, FilePath) -> State FilePath ()) -> State FilePath ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
k, FilePath
v) ->
do FilePath
a <- StateT FilePath Identity FilePath
forall s (m :: * -> *). MonadState s m => m s
get
FilePath -> State FilePath ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (FilePath -> State FilePath ()) -> FilePath -> State FilePath ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
replace FilePath
k FilePath
v FilePath
a
mapFilePath :: (FilePath -> FilePath) -> ExperimentFilePath -> ExperimentFilePath
mapFilePath :: (FilePath -> FilePath) -> ExperimentFilePath -> ExperimentFilePath
mapFilePath FilePath -> FilePath
f (WritableFilePath FilePath
path) = FilePath -> ExperimentFilePath
WritableFilePath (FilePath -> FilePath
f FilePath
path)
mapFilePath FilePath -> FilePath
f (UniqueFilePath FilePath
path) = FilePath -> ExperimentFilePath
UniqueFilePath (FilePath -> FilePath
f FilePath
path)
newtype ExperimentWriter a = ExperimentWriter (MVar (S.Set String) -> IO a)
instance Functor ExperimentWriter where
{-# INLINE fmap #-}
fmap :: forall a b. (a -> b) -> ExperimentWriter a -> ExperimentWriter b
fmap a -> b
f (ExperimentWriter MVar (Set FilePath) -> IO a
m) =
(MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO b) -> ExperimentWriter b)
-> (MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> (a -> b) -> IO a -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r)
instance Applicative ExperimentWriter where
{-# INLINE pure #-}
pure :: forall a. a -> ExperimentWriter a
pure a
a =
(MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO a) -> ExperimentWriter a)
-> (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
{-# INLINE (<*>) #-}
(ExperimentWriter MVar (Set FilePath) -> IO (a -> b)
f) <*> :: forall a b.
ExperimentWriter (a -> b)
-> ExperimentWriter a -> ExperimentWriter b
<*> (ExperimentWriter MVar (Set FilePath) -> IO a
m) =
(MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO b) -> ExperimentWriter b)
-> (MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> MVar (Set FilePath) -> IO (a -> b)
f MVar (Set FilePath)
r IO (a -> b) -> IO a -> IO b
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r
instance Monad ExperimentWriter where
{-# INLINE (>>=) #-}
(ExperimentWriter MVar (Set FilePath) -> IO a
m) >>= :: forall a b.
ExperimentWriter a
-> (a -> ExperimentWriter b) -> ExperimentWriter b
>>= a -> ExperimentWriter b
k =
(MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO b) -> ExperimentWriter b)
-> (MVar (Set FilePath) -> IO b) -> ExperimentWriter b
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
do a
a <- MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r
let ExperimentWriter MVar (Set FilePath) -> IO b
b = a -> ExperimentWriter b
k a
a
MVar (Set FilePath) -> IO b
b MVar (Set FilePath)
r
instance MonadIO ExperimentWriter where
{-# INLINE liftIO #-}
liftIO :: forall a. IO a -> ExperimentWriter a
liftIO IO a
m = (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO a) -> ExperimentWriter a)
-> (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m
instance MonadException ExperimentWriter where
{-# INLINE catchComp #-}
catchComp :: forall e a.
Exception e =>
ExperimentWriter a
-> (e -> ExperimentWriter a) -> ExperimentWriter a
catchComp (ExperimentWriter MVar (Set FilePath) -> IO a
m) e -> ExperimentWriter a
h =
(MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO a) -> ExperimentWriter a)
-> (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r) ((e -> IO a) -> IO a) -> (e -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \e
e ->
let ExperimentWriter MVar (Set FilePath) -> IO a
m' = e -> ExperimentWriter a
h e
e in MVar (Set FilePath) -> IO a
m' MVar (Set FilePath)
r
{-# INLINE finallyComp #-}
finallyComp :: forall a b.
ExperimentWriter a -> ExperimentWriter b -> ExperimentWriter a
finallyComp (ExperimentWriter MVar (Set FilePath) -> IO a
m) (ExperimentWriter MVar (Set FilePath) -> IO b
m') =
(MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO a) -> ExperimentWriter a)
-> (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally (MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r) (MVar (Set FilePath) -> IO b
m' MVar (Set FilePath)
r)
{-# INLINE throwComp #-}
throwComp :: forall e a. Exception e => e -> ExperimentWriter a
throwComp e
e =
(MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter ((MVar (Set FilePath) -> IO a) -> ExperimentWriter a)
-> (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
e -> IO a
forall a e. Exception e => e -> a
throw e
e
runExperimentWriter :: ExperimentWriter a -> IO a
runExperimentWriter :: forall a. ExperimentWriter a -> IO a
runExperimentWriter (ExperimentWriter MVar (Set FilePath) -> IO a
m) =
do MVar (Set FilePath)
r <- Set FilePath -> IO (MVar (Set FilePath))
forall a. a -> IO (MVar a)
newMVar Set FilePath
forall a. Set a
S.empty
MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r