module Control.Monad.EffRef where
import Control.Applicative
import Control.Concurrent
import Control.Exception (evaluate)
import Control.Monad
import Control.Monad.RWS
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.Trans.Identity
import System.Directory
import System.FSNotify
import Filesystem.Path hiding (FilePath)
import Filesystem.Path.CurrentOS hiding (FilePath)
import Control.Monad.Operational
import Control.Monad.Restricted
import Control.Monad.ExtRef
import Control.Monad.ExtRef.Pure
class ExtRef m => EffRef m where
type CallbackM m :: * -> *
type EffectM m :: * -> *
liftEffectM' :: Morph (EffectM m) m
onChange :: Eq a => Bool -> ReadRef m a -> (a -> m (m ())) -> m ()
toReceive :: Eq a => (a -> WriteRef m ()) -> (Command -> EffectM m ()) -> m (a -> CallbackM m ())
data Command = Kill | Block | Unblock deriving (Eq, Ord, Show)
rEffect :: (EffRef m, Eq a) => Bool -> ReadRef m a -> (a -> EffectM m ()) -> m ()
rEffect init r f = onChange init r $ return . liftEffectM' . f
type SyntEffRef n m x = Program (EffRefI n m x)
data EffRefI n m x a where
SyntLiftEffect :: m a -> EffRefI n m x a
SyntLiftExtRef :: SyntExtRef x a -> EffRefI n m x a
SyntOnChange :: Eq a => Bool -> SyntRefReader x a -> (a -> SyntEffRef n m x (SyntEffRef n m x ())) -> EffRefI n m x ()
SyntReceive :: Eq a => (a -> SyntRefState x ()) -> (Command -> m ()) -> EffRefI n m x (a -> n ())
instance ExtRef (SyntEffRef n m x) where
type Ref (SyntEffRef n m x) = SyntRef x
liftWriteRef w = singleton $ SyntLiftExtRef $ liftWriteRef w
extRef r l a = singleton $ SyntLiftExtRef $ extRef r l a
newRef a = singleton $ SyntLiftExtRef $ newRef a
liftEffectM = singleton . SyntLiftEffect
instance EffRef (SyntEffRef n m x) where
type EffectM (SyntEffRef n m x) = m
type CallbackM (SyntEffRef n m x) = n
liftEffectM' = singleton . SyntLiftEffect
onChange b r f = singleton $ SyntOnChange b r f
toReceive f g = singleton $ SyntReceive f g
type CO m = WriterT (MonadMonoid m, Command -> MonadMonoid m) m
evalRegister' :: (NewRef m) => (StateT LSt m () -> m ()) -> SyntEffRef m (StateT LSt m) (Lens_ LSt) a -> CO (StateT LSt m) a
evalRegister' ff = eval . view
where
eval (Return x) = return x
eval (SyntLiftEffect m :>>= k) = lift m >>= evalRegister' ff . k
eval (SyntLiftExtRef m :>>= k) = lift (runExtRef m) >>= evalRegister' ff . k
eval (SyntReceive f g :>>= k) = tell (t2 g) >> evalRegister' ff (k $ ff . runExtRef . liftWriteRef . f)
eval (SyntOnChange b r f :>>= k) = toSend__ b (runExtRef $ liftReadRef r) (liftM (evalRegister' ff) . evalRegister' ff . f) >>= evalRegister' ff . k
newRef'' x = liftM (\r -> MorphD $ \m -> StateT $ \s -> runMorphD r $ mapStateT (\k -> runStateT k s >>= \((x, w), s) -> return ((x, s), w)) m) $ newRef' x
toSend__ init rb fb = do
b <- lift rb
v <- case init of
False -> return $ Left b
True -> lift $ do
(c, (s1, ureg1)) <- runWriterT (fb b)
(s2, ureg2) <- execWriterT c
runMonadMonoid $ s1 `mappend` s2
return $ Right [(b, (c, s1, s2, ureg1, ureg2))]
memoref <- lift $ lift $ newRef'' v
tell $ t1 $ do
b <- rb
join $ runMorphD memoref $ StateT $ \memo -> case memo of
Left b' | b' == b -> return (return (), memo)
Right ((b', (_, s1, s2, _, _)): _) | b' == b ->
return (runMonadMonoid $ s1 `mappend` s2, memo)
_ -> do
case memo of
Right ((_, (_, _, _, ureg1, ureg2)): _) ->
runMonadMonoid $ ureg1 Block `mappend` ureg2 Kill
_ -> return ()
(c, (s1, ureg1)) <- case filter ((== b) . fst) $ either (const []) id memo of
((_, (c, s1, _, ureg1, _)): _) -> do
runMonadMonoid $ ureg1 Unblock
return (c, (s1, ureg1))
_ -> runWriterT (fb b)
(s2, ureg2) <- execWriterT c
let memo' = Right $ (:) (b, (c, s1, s2, ureg1, ureg2)) $ filter ((/= b) . fst) $ either (const []) id memo
return (runMonadMonoid $ s1 `mappend` s2, memo')
t1 m = (MonadMonoid m, mempty)
t2 m = (mempty, MonadMonoid . m)
class (EffRef m, SafeIO m, SafeIO (ReadRef m)) => EffIORef m where
asyncWrite_ :: Eq a => Int -> (a -> WriteRef m ()) -> a -> m ()
fileRef :: FilePath -> m (Ref m (Maybe String))
getLine_ :: (String -> WriteRef m ()) -> m ()
putStr_ :: EffIORef m => String -> m ()
putStrLn_ :: EffIORef m => String -> m ()
putStrLn_ = putStr_ . (++ "\n")
asyncWrite :: EffIORef m => Int -> (a -> WriteRef m ()) -> a -> m ()
asyncWrite t f a = asyncWrite' t $ f a
asyncWrite' :: EffIORef m => Int -> WriteRef m () -> m ()
asyncWrite' t r = asyncWrite_ t (const r) ()
type SyntEffIORef m x = SyntEffRef m (StateT LSt m) x
instance SafeIO (SyntRefReader x) where
instance SafeIO (SyntEffIORef m x) where
instance EffIORef (SyntEffIORef IO x) where
asyncWrite_ t r a = do
(u, f) <- liftIO' forkIOs'
x <- toReceive r $ liftIO . u
liftIO' $ f [ threadDelay t, x a ]
fileRef f = do
ms <- liftIO' r
ref <- newRef ms
v <- liftIO' newEmptyMVar
vman <- liftIO' newEmptyMVar
cf <- liftIO' $ canonicalizePath f
let
cf' = decodeString cf
g = (== cf')
h = tryPutMVar v () >> return ()
filt (Added x _) = g x
filt (Modified x _) = g x
filt (Removed x _) = g x
act (Added _ _) = putStrLn "added" >> h
act (Modified _ _) = putStrLn "mod" >> h
act (Removed _ _) = putStrLn "rem" >> h
startm = do
putStrLn " start"
man <- startManager
putMVar vman $ putStrLn " stop" >> stopManager man
watchDir man (directory cf') filt act
liftIO' startm
(u, ff) <- liftIO' forkIOs'
re <- toReceive (writeRef ref) $ liftIO . u
liftIO' $ ff $ repeat $ takeMVar v >> r >>= re
rEffect False (readRef ref) $ \x -> liftIO $ do
join $ takeMVar vman
_ <- tryTakeMVar v
putStrLn " write"
w x
threadDelay 10000
startm
return ref
where
r = do
b <- doesFileExist f
if b then do
xs <- readFile f
_ <- evaluate (length xs)
return (Just xs)
else return Nothing
w = maybe (doesFileExist f >>= \b -> when b (removeFile f)) (writeFile f)
getLine_ w = do
(u, f) <- liftIO' forkIOs'
x <- toReceive w $ liftIO . u
liftIO' $ f [ getLine >>= x ]
putStr_ s = liftIO' $ putStr s
liftIO__ :: Monad m => m a -> SyntEffIORef m (Lens_ LSt) a
liftIO__ m = singleton $ SyntLiftEffect $ lift m
liftIO' m = liftEffectM $ liftIO m
forkIOs' = do
x <- newMVar ()
s <- newEmptyMVar
let g = do
readMVar x
is <- takeMVar s
case is of
[] -> return ()
(i:is) -> do
putMVar s is
i
g
f i Kill = killThread i
f _ Block = takeMVar x
f _ Unblock = putMVar x ()
i <- forkIO g
return (f i, putMVar s)