module Reanimate.Driver ( reanimate ) where

import           Control.Concurrent (MVar, forkIO, killThread, modifyMVar_,
                                     newEmptyMVar, putMVar)
import           Control.Exception  (finally)
import           Control.Monad.Fix  (fix)
import qualified Data.Text          as T
import           Network.WebSockets
import           System.Directory   (findFile, listDirectory)
import           System.Environment (getArgs, getProgName)
import           System.FilePath
import           System.FSNotify
import           System.IO          (BufferMode (..), hPutStrLn, hSetBuffering,
                                     stderr, stdin)

import           Data.Maybe
import           Paths_reanimate
import           Reanimate.Misc     (runCmdLazy, runCmd_, withTempDir,
                                     withTempFile)
import           Reanimate.Monad    (Animation)
import           Reanimate.Render   (renderSvgs, render)
import           Web.Browser        (openBrowser)

opts = defaultConnectionOptions
  { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }

reanimate :: Animation -> IO ()
reanimate animation = do
  watch <- startManager
  args <- getArgs
  hSetBuffering stdin NoBuffering
  case args of
    ["once"] -> renderSvgs animation
    ["render", target] ->
      render animation target
    _ -> withTempDir $ \tmpDir -> do
      url <- getDataFileName "viewer/build/index.html"
      putStrLn "Opening browser..."
      bSucc <- openBrowser url
      if bSucc
          then putStrLn "Browser opened."
          else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
      runServerWith "127.0.0.1" 9161 opts $ \pending -> do
        putStrLn "Server pending..."
        prog <- getProgName
        lst <- listDirectory "."
        mbSelf <- findFile ("." : lst) prog
        blocker <- newEmptyMVar :: IO (MVar ())
        case mbSelf of
          Nothing -> do
            hPutStrLn stderr "Failed to find own source code."
          Just self -> do
            conn <- acceptRequest pending
            slave <- newEmptyMVar
            let handler = modifyMVar_ slave $ \tid -> do
                  sendTextData conn (T.pack "Compiling")
                  putStrLn "Killing and respawning..."
                  killThread tid
                  tid <- forkIO $ withTempFile ".exe" $ \tmpExecutable -> do
                    ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]
                    case ret of
                      Left err ->
                        sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
                      Right{} -> do
                        getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M200M", "-RTS"]
                        flip fix [] $ \loop acc -> do
                          frame <- getFrame
                          case frame of
                            Left "" -> do
                              sendTextData conn (T.pack "Done")
                              -- insertCache msg (reverse acc)
                            Left err -> do
                              -- _ <- getChanContents queue
                              sendTextData conn $ T.pack $ "Error" ++ err
                            Right frame -> do
                              sendTextData conn frame
                              loop (frame : acc)
                  return tid
            putStrLn "Found self. Listening..."
            stop <- watchFile watch self handler
            putMVar slave =<< forkIO (return ())
            let loop = do
                  fps <- receiveData conn :: IO T.Text
                  handler
                  loop
            loop `finally` stop

watchFile watch file action = watchDir watch (takeDirectory file) check (const action)
  where
    check event = takeFileName (eventPath event) == takeFileName file

ghcOptions :: FilePath -> [String]
ghcOptions tmpDir =
    ["-rtsopts", "--make", "-threaded", "-O2"] ++
    ["-odir", tmpDir, "-hidir", tmpDir]