-- |
-- 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) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
path
resolveFilePath FilePath
dir (UniqueFilePath FilePath
path)   =
  forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter 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 forall a. [a] -> [a] -> [a]
++ FilePath
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show t
i 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 forall a. Num a => a -> a -> a
+ t
1)
             else do Maybe FilePath
n' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                           forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Set FilePath)
r forall a b. (a -> b) -> a -> b
$ \Set FilePath
s ->
                           if forall a. Ord a => a -> Set a -> Bool
S.member FilePath
n Set FilePath
s
                           then forall (m :: * -> *) a. Monad m => a -> m a
return (Set FilePath
s, forall a. Maybe a
Nothing)
                           else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
n Set FilePath
s, 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 forall a. Num a => a -> a -> a
+ t
1)
                       Just FilePath
n' -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
n'
  in forall {t}. (Num t, Show t) => FilePath -> t -> 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') = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState FilePath
name forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.assocs Map FilePath FilePath
map) forall a b. (a -> b) -> a -> b
$ \(FilePath
k, FilePath
v) ->
                do FilePath
a <- forall s (m :: * -> *). MonadState s m => m s
get
                   forall s (m :: * -> *). MonadState s m => s -> m ()
put 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 :: forall a b. (a -> b) -> ExperimentWriter a -> ExperimentWriter b
fmap a -> b
f (ExperimentWriter MVar (Set FilePath) -> IO a
m) =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> 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 =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> 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) =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> MVar (Set FilePath) -> IO (a -> b)
f MVar (Set FilePath)
r 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 =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter 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 = forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r -> 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 =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r) 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') =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
    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 =
    forall a. (MVar (Set FilePath) -> IO a) -> ExperimentWriter a
ExperimentWriter forall a b. (a -> b) -> a -> b
$ \MVar (Set FilePath)
r ->
    forall a e. Exception e => e -> a
throw e
e

-- | Run the 'ExperimentWriter' computation.
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 <- forall a. a -> IO (MVar a)
newMVar forall a. Set a
S.empty
     MVar (Set FilePath) -> IO a
m MVar (Set FilePath)
r