module HERMIT.Kernel.Scoped
( Direction(..)
, LocalPath
, moveLocally
, ScopedKernel(..)
, SAST(..)
, scopedKernel
) where
import Control.Arrow
import Control.Concurrent.STM
import Control.Exception (bracketOnError)
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import qualified Data.IntMap as I
import HERMIT.Core
import HERMIT.Context
import HERMIT.Kure
import HERMIT.GHC hiding (Direction,L)
import HERMIT.Monad
import HERMIT.Kernel
data Direction = L
| R
| U
| T
deriving (Eq,Show)
pathStack2Paths :: [LocalPath crumb] -> LocalPath crumb -> [Path crumb]
pathStack2Paths ps p = reverse (map snocPathToPath (p:ps))
moveLocally :: Direction -> LocalPathH -> LocalPathH
moveLocally d (SnocPath p) = case p of
[] -> mempty
cr:crs -> case d of
T -> mempty
U -> SnocPath crs
L -> SnocPath (fromMaybe cr (deprecatedLeftSibling cr) : crs)
R -> SnocPath (fromMaybe cr (deprecatedRightSibling cr) : crs)
pathStackToLens :: (Injection ModGuts g, Walker HermitC g) => [LocalPathH] -> LocalPathH -> LensH ModGuts g
pathStackToLens ps p = injectL >>> pathL (concat $ pathStack2Paths ps p)
testPathStackT :: [LocalPathH] -> LocalPathH -> TranslateH ModGuts Bool
testPathStackT ps p = testLensT (pathStackToLens ps p :: LensH ModGuts CoreTC)
data ScopedKernel = ScopedKernel
{ resumeS :: (MonadIO m, MonadCatch m) => SAST -> m ()
, abortS :: MonadIO m => m ()
, applyS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g)
=> RewriteH g -> HermitMEnv -> SAST -> m SAST
, queryS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g)
=> TranslateH g a -> HermitMEnv -> SAST -> m a
, deleteS :: (MonadIO m, MonadCatch m) => SAST -> m ()
, listS :: MonadIO m => m [SAST]
, pathS :: (MonadIO m, MonadCatch m) => SAST -> m [PathH]
, modPathS :: (MonadIO m, MonadCatch m)
=> (LocalPathH -> LocalPathH) -> HermitMEnv -> SAST -> m SAST
, beginScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST
, endScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST
, kernelS :: Kernel
, toASTS :: (MonadIO m, MonadCatch m) => SAST -> m AST
}
newtype SAST = SAST Int deriving (Eq, Ord, Show)
type SASTStore = I.IntMap (AST, [LocalPathH], LocalPathH)
get :: Monad m => Int -> SASTStore -> m (AST, [LocalPathH], LocalPathH)
get sAst m = maybe (fail "scopedKernel: invalid SAST") return (I.lookup sAst m)
safeTakeTMVar :: (MonadCatch m, MonadIO m) => TMVar a -> (a -> IO b) -> m b
safeTakeTMVar mvar = liftAndCatchIO . bracketOnError (atomically $ takeTMVar mvar) (atomically . putTMVar mvar)
scopedKernel :: (ScopedKernel -> SAST -> IO ()) -> ModGuts -> CoreM ModGuts
scopedKernel callback = hermitKernel $ \ kernel initAST -> do
store <- newTMVarIO $ I.fromList [(0,(initAST, [], mempty))]
key <- newTMVarIO (1::Int)
let newKey = do
k <- takeTMVar key
putTMVar key (k+1)
return k
skernel = ScopedKernel
{ resumeS = \ (SAST sAst) -> liftAndCatchIO $ do
m <- atomically $ readTMVar store
(ast,_,_) <- get sAst m
resumeK kernel ast
, abortS = liftIO $ abortK kernel
, applyS = \ rr env (SAST sAst) -> safeTakeTMVar store $ \ m -> do
(ast, base, rel) <- get sAst m
applyK kernel ast (focusR (pathStackToLens base rel) rr) env
>>= runKureM (\ ast' -> atomically $ do k <- newKey
putTMVar store $ I.insert k (ast', base, rel) m
return $ SAST k)
fail
, queryS = \ t env (SAST sAst) -> liftAndCatchIO $ do
m <- atomically $ readTMVar store
(ast, base, rel) <- get sAst m
queryK kernel ast (focusT (pathStackToLens base rel) t) env
>>= liftKureM
, deleteS = \ (SAST sAst) -> safeTakeTMVar store $ \ m -> do
(ast,_,_) <- get sAst m
let m' = I.delete sAst m
fst3 (x,_,_) = x
asts = I.foldr ((:) . fst3) [] m'
when (ast `notElem` asts) $ deleteK kernel ast
atomically $ putTMVar store m'
, listS = do m <- liftIO $ atomically $ readTMVar store
return [ SAST sAst | sAst <- I.keys m ]
, pathS = \ (SAST sAst) -> liftAndCatchIO $ do
m <- atomically $ readTMVar store
(_, base, rel) <- get sAst m
return $ pathStack2Paths base rel
, modPathS = \ f env (SAST sAst) -> safeTakeTMVar store $ \ m -> do
(ast, base, rel) <- get sAst m
let rel' = f rel
queryK kernel ast (testPathStackT base rel') env
>>= runKureM (\ b -> if rel == rel'
then fail "Path is unchanged, nothing to do."
else if b
then atomically $ do k <- newKey
putTMVar store $ I.insert k (ast, base, rel') m
return $ SAST k
else fail "Invalid path created.")
fail
, beginScopeS = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do
(ast, base, rel) <- get sAst m
atomically $ do k <- newKey
putTMVar store $ I.insert k (ast, rel : base, mempty) m
return $ SAST k
, endScopeS = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do
(ast, base, _) <- get sAst m
case base of
[] -> fail "Scoped Kernel: no scope to end."
rel : base' -> atomically $ do k <- newKey
putTMVar store $ I.insert k (ast, base', rel) m
return $ SAST k
, kernelS = kernel
, toASTS = \ (SAST sAst) -> liftAndCatchIO $ do
m <- atomically $ readTMVar store
(ast, _, _) <- get sAst m
return ast
}
callback skernel $ SAST 0