Rebuild.hs

module Chromatin.Rebuild(
  crmRebuild,
) where

import Conduit (ConduitT, (.|), runConduit, mapMC, sinkList, await, yield)
import Control.Concurrent.STM.TBMChan (TBMChan, newTBMChan, writeTBMChan, closeTBMChan)
import qualified Control.Lens as Lens (set)
import Control.Monad.Trans.Class (lift)
import Data.Conduit.TMChan (sourceTBMChan)
import Data.Foldable (traverse_)
import Data.Functor (void)
import Data.Void (Void)
import UnliftIO (atomically)
import UnliftIO.STM (TVar, STM)
import Neovim (CommandArguments)
import Ribosome.Control.Ribo (Ribo)
import qualified Ribosome.Control.Ribo as Ribo (inspect, modify)
import Ribosome.Data.ScratchOptions (defaultScratchOptions)
import Ribosome.Internal.IO (forkNeovim)
import Ribosome.Scratch (showInScratch)
import Chromatin.Data.ActiveRplugin (ActiveRplugin)
import Chromatin.Data.Chromatin (Chromatin)
import Chromatin.Data.Env (Env)
import qualified Chromatin.Data.Env as Env (installerChan, _installerChan)
import Chromatin.Data.RebuildTask (RebuildTask(..))
import Chromatin.Data.RebuildControl (RebuildControl)
import qualified Chromatin.Data.RebuildControl as RebuildControl (RebuildControl(..))
import Chromatin.Data.RunExistingResult (RunExistingResult)
import Chromatin.Data.RunBuiltResult (RunBuiltResult)
import qualified Chromatin.Data.RunBuiltResult as RunBuiltResult (RunBuiltResult(..))
import Chromatin.Data.RpluginName (RpluginName(RpluginName))
import Chromatin.Data.RpluginSource (RpluginSource)
import Chromatin.Config (readConfig, analyzeConfigIO, RpluginModification(RpluginNew))
import Chromatin.Rebuild.Existing (handleExisting)
import Chromatin.Rebuild.Init (initializeRplugins)
import Chromatin.Rebuild.Nonexisting (handleNonexisting)
import qualified Chromatin.Log as Log

mapMChan :: Chromatin a -> (TBMChan RebuildControl -> Chromatin a) -> Chromatin a
mapMChan fEmpty f = do
  storedChan <- Ribo.inspect Env.installerChan
  maybe fEmpty f storedChan

stopRebuilder :: Chromatin ()
stopRebuilder =
  mapMChan (return ()) $ \c -> do
    Ribo.modify $ Lens.set Env._installerChan Nothing
    atomically $ closeTBMChan c
    Log.debug "stopped installer conduit"

createChan :: STM (TBMChan RebuildControl)
createChan = newTBMChan 64

extractFailure :: RunBuiltResult -> [String]
extractFailure (RunBuiltResult.Failure (RebuildTask (RpluginName name) _) err) =
  ("error when runnning plugin `" ++ name ++ "`:") : err
extractFailure (RunBuiltResult.Success _) = []
extractFailure (RunBuiltResult.PreviousFailure stage (RebuildTask (RpluginName name) _) err) =
  ("error in stage `" ++ stage ++ "` for plugin `" ++ name ++ "`:") : err

extractSuccess :: RunBuiltResult -> [ActiveRplugin]
extractSuccess (RunBuiltResult.Success arp) = [arp]
extractSuccess _ = []

controlC :: ConduitT RebuildControl RebuildTask (Ribo (TVar Env)) ()
controlC = do
  ctrl <- await
  case ctrl of
    Just RebuildControl.Stop -> lift stopRebuilder
    Just (RebuildControl.Continue task) -> yield task >> controlC
    Nothing -> controlC

handleExistingC :: ConduitT RebuildTask RunExistingResult (Ribo (TVar Env)) ()
handleExistingC = mapMC handleExisting

handleNonexistingC :: ConduitT RunExistingResult RunBuiltResult (Ribo (TVar Env)) ()
handleNonexistingC = mapMC handleNonexisting

rebuilder :: TBMChan RebuildControl -> ConduitT () Void (Ribo (TVar Env)) [RunBuiltResult]
rebuilder chan = sourceTBMChan chan
  .| controlC
  .| handleExistingC
  .| handleNonexistingC
  .| sinkList

runRebuilder :: TBMChan RebuildControl -> Chromatin ()
runRebuilder chan = do
  result <- runConduit $ rebuilder chan
  case concatMap extractFailure result of
    err@(_:_) -> void $ showInScratch err (defaultScratchOptions "chromatin-rebuild-error")
    _ -> return ()
  initializeRplugins (concatMap extractSuccess result)
  Log.debug $ "installer terminated: " ++ show result

forkRebuilder :: Chromatin (TBMChan RebuildControl)
forkRebuilder = do
  chan <- atomically createChan
  Ribo.modify $ Lens.set Env._installerChan (Just chan)
  forkNeovim $ runRebuilder chan
  return chan

enqueue :: RebuildControl -> TBMChan RebuildControl -> Chromatin ()
enqueue ctrl chan = atomically $ writeTBMChan chan ctrl

executeRpluginNew :: RpluginName -> RpluginSource -> Chromatin ()
executeRpluginNew name source = do
  chan <- mapMChan forkRebuilder return
  enqueue (RebuildControl.Continue (RebuildTask name source)) chan

executeModification :: RpluginModification -> Chromatin ()
executeModification (RpluginNew name source) = executeRpluginNew name source
executeModification _ = return ()

executeModifications :: [RpluginModification] -> Chromatin ()
executeModifications mods = do
  traverse_ executeModification mods
  mapMChan (return ()) (enqueue RebuildControl.Stop)

analysisError :: String -> Chromatin ()
analysisError _ = return ()

crmRebuild :: CommandArguments -> Chromatin ()
crmRebuild _ = do
  config <- readConfig
  analysis <- analyzeConfigIO config
  case analysis of
    Right mods -> executeModifications mods
    Left e -> analysisError e