{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Salak.Load.Dynamic where
import Control.Concurrent.MVar
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State
import Control.Monad.Writer
import qualified Data.IntMap.Strict as MI
import Data.Text (Text)
import Salak.Prop
import Salak.Types
import Salak.Types.Source
data ReloadResult = ReloadResult
{ isError :: Bool
, msg :: [String]
} deriving (Eq, Show)
data ReloadableSourcePack = ReloadableSourcePack
{ sourcePack :: MVar SourcePack
, reloadAll :: (SourcePack -> IO ([IO ()], [String])) -> IO ReloadResult
}
reloadableSourcePack :: MonadIO m => SourcePack -> m ReloadableSourcePack
reloadableSourcePack sp = do
msp <- liftIO $ newMVar sp
return $ ReloadableSourcePack msp (reloadAll' msp)
where
reloadAll' v f = do
sp' <- readMVar v
as <- sequence $ MI.foldlWithKey' go [] (reEnv sp')
let loadErr = concat $ fst . snd <$> as
runWith e a = if null e then a else return $ ReloadResult True e
runWith loadErr $ do
let sp'' = foldl g2 sp' {errs = []} as
modLog = errs sp''
(ac, msErr) <- f sp''
runWith msErr $ putMVar v sp'' >> sequence_ ac >> return (ReloadResult False modLog)
go b i (Reload _ f) = ((i,) <$> f i) : b
g2 :: SourcePack -> (Int, ([String], Source)) -> SourcePack
g2 p (i, (_, s)) = let (s', e) = runWriter $ replace i s (source p) in p { source = s', errs = errs p <> e}
newtype RunSalakT m a = RunSalakT { unRun :: StateT ReloadableSourcePack m a }
deriving (Functor, Applicative, Monad, MonadTrans)
instance MonadIO m => MonadIO (RunSalakT m) where
liftIO = lift . liftIO
askRSP :: MonadIO m => RunSalakT m SourcePack
askRSP = RunSalakT $ do
ReloadableSourcePack{..} <- get
liftIO $ readMVar sourcePack
search' :: (MonadIO m, FromProp a) => Text -> RunSalakT m (Either String (IO a))
search' k = RunSalakT $ do
sp <- unRun askRSP
case search k sp of
Left e -> return (Left e)
Right r -> do
v <- liftIO $ newMVar r
modify $ \rsp -> rsp { reloadAll = reloadAll rsp . go v}
return $ Right $ readMVar v
where
go x f sp = do
(as,es) <- f sp
case search k sp of
Left e -> return (as, e:es)
Right r -> return (putMVar x r:as, es)
reloadAction :: Monad m => RunSalakT m (IO ReloadResult)
reloadAction = RunSalakT $ do
ReloadableSourcePack{..} <- get
return $ reloadAll $ \_ -> return ([], [])
runT :: MonadIO m => RunSalakT m a -> SourcePack -> m a
runT (RunSalakT a) sp = reloadableSourcePack sp >>= evalStateT a
exec :: MonadIO m => (IO ReloadResult -> IO a) -> RunSalakT m a
exec fa = reloadAction >>= lift . liftIO . fa