-- |
-- Module     : Simulation.Aivika.Experiment.Base.ExperimentWriter
-- Copyright  : Copyright (c) 2012-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- It defines the 'Exp' monad that allows providing computation with
-- an ability to resolve file paths.
--
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)
  
-- | Specifies the file name, unique or writable, which can be appended with extension if required.
data ExperimentFilePath = WritableFilePath FilePath
                          -- ^ The file which is overwritten in 
                          -- case if it existed before.
                        | UniqueFilePath FilePath
                          -- ^ The file which is always unique,
                          -- when an automatically generated suffix
                          -- is added to the name in case of need.

-- | The default experiment file path.
experimentFilePath :: ExperimentFilePath
experimentFilePath :: ExperimentFilePath
experimentFilePath = FilePath -> ExperimentFilePath
UniqueFilePath FilePath
"experiment"
                
-- | Resolve the file path relative to the specified directory passed in the first argument
-- and taking into account a possible requirement to have an unique file name.
resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath
resolveFilePath :: FilePath -> ExperimentFilePath -> ExperimentWriter FilePath
resolveFilePath FilePath
dir (WritableFilePath FilePath
path) =
  FilePath -> ExperimentWriter FilePath
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 -> a -> IO FilePath
loop FilePath
y a
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]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
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 -> a -> IO FilePath
loop FilePath
y' (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
             else do Maybe FilePath
n' <- IO (Maybe FilePath) -> IO (Maybe FilePath)
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 (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 (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 -> a -> IO FilePath
loop FilePath
y' (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
                       Just FilePath
n' -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
n'
  in FilePath -> Integer -> IO FilePath
forall a. (Num a, Show a) => FilePath -> a -> IO FilePath
loop FilePath
name Integer
2

-- | Expand the file path using the specified table of substitutions.
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)

-- | Expand the string templates using the specified table of substitutions.
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

-- | Transform the file path using the specified function.
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) 


-- | Defines an 'IO' derived computation whithin which we can resolve the unique file paths.
newtype ExperimentWriter a = ExperimentWriter (MVar (S.Set String) -> IO a)

instance Functor ExperimentWriter where

  {-# INLINE fmap #-}
  fmap :: (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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
a

  {-# INLINE (<*>) #-}
  (ExperimentWriter MVar (Set FilePath) -> IO (a -> b)
f) <*> :: 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 (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 return #-}
  return :: a -> ExperimentWriter a
return 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 (m :: * -> *) a. Monad m => a -> m a
return a
a

  {-# INLINE (>>=) #-}
  (ExperimentWriter MVar (Set FilePath) -> IO a
m) >>= :: 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 :: 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m

instance MonadException ExperimentWriter where

  {-# INLINE catchComp #-}
  catchComp :: 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 :: 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 :: 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

-- | Run the 'ExperimentWriter' computation.
runExperimentWriter :: ExperimentWriter a -> IO a
runExperimentWriter :: 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