Queue.hs

module Export.Queue where

import Terminal.Game
import Export.Gif
import Parse
import Config

import Control.Concurrent
import System.FilePath
import Control.Monad

import System.Directory
import System.FilePath


-- queue of files to process.
type JobQueue = MVar [FilePath]
createQueue :: IO (MVar [FilePath])
createQueue = newMVar []

startQueue :: Config -> JobQueue -> ResQueue -> IO ()
startQueue c mv mrq = -- mvar sarà sempre piena
                  takeMVar mv >>= \fl ->
                  case fl of
                    []     -> putMVar mv []
                    (f:fs) -> putMVar mv fs   >>
                              doRenderJob c f mrq
                  >> threadDelay second
                  >> startQueue c mv mrq
    where
          second = 10^6

addRenderJob :: FilePath -> MVar [FilePath] -> IO ()
addRenderJob fp mv = takeMVar mv >>= putMVar mv . (\fs -> fs ++ [fp])

-- Nothing == Ok, String == Exception
doRenderJob :: Config -> FilePath -> MVar [String] -> IO ()
doRenderJob c f rq =
        let gb  = cGif c
            sb  = cSerial c
            fps = cFPS c
            clp = cColours c

            flg = replaceOutExt c f "gif"
            fls = replaceOutExt c f "slz"
        in

        readAnimation f >>= \efms ->

        case efms of
          Left e    -> addResult rq f "failed on readAnimation"
          Right fms -> when gb (addResult rq flg "GIF export in progress..." >>
                                writeGif fps flg clp fms >>= \r ->
                                let r' = maybe "GIF done!" show r in
                                addResult rq flg r'
                               ) >>
                       when sb (addResult rq fls "Serialising..." >>
                                encodeAni fls fms >>
                                addResult rq fls ": serialisation done!"
                               )

-- in $outfolder
replaceOutExt :: Config -> FilePath -> String -> FilePath
replaceOutExt c fp ne = let out = cODir c
                            (dir, file) = splitFileName fp
                            name = dropExtension file
                            bdir = takeDirectory . takeDirectory $ dir
                        in
                        bdir </> out </> name <.> ne

-- queue of results of processing
type ResQueue = MVar [String]
createResultQueue :: IO (MVar [String])
createResultQueue = newMVar []

addResult :: MVar [String] -> FilePath -> String -> IO ()
addResult mrs fp r =
                takeMVar mrs        >>= \rs ->
                getCurrentDirectory >>= \cwd ->
                let fp' = makeRelative cwd fp
                    rs' = rs ++ [stringResult fp' r] in
                putMVar mrs rs'
    where
          stringResult :: FilePath -> String -> String
          stringResult fp r = fp ++ ": " ++ r

getResults :: ResQueue -> IO [String]
getResults rq = takeMVar rq   >>= \rs ->
                putMVar rq [] >>
                return rs