module Control.Biegunka.Execute.Settings
( Executor, env
, Execution
, Mip(..), lookup, insert, delete, singleton, fromList, null, keys, elems, assocs
, execution, watch, user, repos
, initializeSTM
, Work(..)
) where
import Control.Applicative
import Control.Concurrent.STM.TVar (TVar, newTVarIO)
import Control.Lens
import Data.Functor.Trans.Tagged
import Data.Monoid (mempty)
import Data.Reflection (Reifies)
import Data.List (foldl')
import Data.Set (Set)
import Prelude hiding (lookup, null)
import System.Posix.Types (CUid)
import Control.Biegunka.Execute.Watcher (Watcher)
import Control.Biegunka.Settings (Settings, local)
type Executor s a = TaggedT s IO a
env :: (Applicative m, Reifies s a) => TaggedT s m a
env = reflected
data Mip k a = Empty | Mip k a
deriving (Show, Read, Eq, Ord)
instance Functor (Mip k) where
fmap _ Empty = Empty
fmap f (Mip k a) = Mip k (f a)
lookup :: Eq k => k -> Mip k a -> Maybe a
lookup _ Empty = Nothing
lookup k' (Mip k a) = bool Nothing (Just a) (k == k')
insert :: Eq k => k -> a -> Mip k a -> Mip k a
insert k a Empty = Mip k a
insert k a x@(Mip k' _) = bool x (Mip k a) (k == k')
delete :: Eq k => k -> Mip k a -> Mip k a
delete _ Empty = Empty
delete k' x@(Mip k _) = bool x Empty (k == k')
bool :: a -> a -> Bool -> a
bool f t p = if p then t else f
type instance Index (Mip k a) = k
type instance IxValue (Mip k a) = a
instance (Applicative f, Eq k) => Ixed f (Mip k a) where
ix = ixAt
instance Eq k => At (Mip k a) where
at k f m = indexed f k mv <&> \r -> case r of
Nothing -> maybe m (const (delete k m)) mv
Just v -> insert k v m
where
mv = lookup k m
singleton :: k -> a -> Mip k a
singleton = Mip
fromList :: Eq k => [(k, a)] -> Mip k a
fromList = foldl' (\a (k, v) -> insert k v a) Empty
null :: Mip k a -> Bool
null Empty = True
null (Mip _ _) = False
keys :: Mip k a -> Maybe k
keys Empty = Nothing
keys (Mip k _) = Just k
elems :: Mip k a -> Maybe a
elems Empty = Nothing
elems (Mip _ a) = Just a
assocs :: Mip k a -> Maybe (k, a)
assocs Empty = Nothing
assocs (Mip k v) = Just (k, v)
data Execution = Execution
{ _watch :: Watcher
, _user :: TVar (Mip CUid Int)
, _repos :: TVar (Set String)
}
data Work =
Do (IO ())
| Stop
makeClassy ''Execution
instance HasExecution (Settings Execution) where
execution = local
initializeSTM :: Watcher -> IO Execution
initializeSTM watcher = Execution watcher
<$> newTVarIO Empty
<*> newTVarIO mempty