I am working with the machines library and I have three Processes
foo :: Process a b
bar :: Process b a
baz :: Process b c
I would like to compose them such that both bar and baz use the output of foo as input. Moreover, and this is the part I'm struggling with, I would like to fed the output of bar back into foo, forming a cycle. Any hints on how to do it?
First you can use ~> to compose processes sequentially (Process x y -> Process y z -> Process x z), so the problem reduces to interpreting Process a a, which you can do with a recursive function carrying a buffer. The buffer gets extended by Yield and consumed by Await. There is some arbitrariness in how you want to handle Await on an empty buffer; here I just take the "no input" continuation and resume normally.
{-# LANGUAGE GADTs #-}
import Data.Machine
import Data.Machine.Process
loop :: Monad m => ProcessT m a a -> m ()
loop p = go [] p where
go :: Monad m => [a] -> ProcessT m a a -> m ()
go buffer p = runMachineT p >>= \s -> case s of
Stop -> pure ()
Yield o p -> go (buffer ++ [o]) p
Await p1 Refl p0 ->
case buffer of
[] -> go [] p0
i : buffer' -> go buffer' (p1 i)
loop3 :: Monad m => ProcessT m a b -> ProcessT m b c -> ProcessT m c a -> m ()
loop3 x y z = loop (x ~> y ~> z)
example :: ProcessT IO String String
example =
encased (Yield "world" (
encased (Await (\name ->
MachineT (putStrLn ("Hello " ++ name ++ "!") >> pure Stop)) Refl (error "No input"))))
main :: IO ()
main = loop example
Related
This is a repost of my previous question(deleted by myself) since I considered it would be adequate to change the focus by presenting the sample code below.
Basically, I try to implement a Functor that takes a function such as id, \a -> a + 1 or even print .
So the function type can be
f :: a -> b
f :: a -> IO ()
module Main where
import Control.Monad.Primitive (PrimMonad (PrimState))
import qualified Data.Vector.Mutable as M
import System.IO.Error (isDoesNotExistErrorType)
main :: IO ()
main = do
let ioA = io (5 :: Int)
let f = print
-- f = \a -> a + 1
let ioB = someFunctor f ioA
ioB
print "done"
data R a = R
{ val :: M.MVector (PrimState IO) a
}
io :: a -> IO (R a)
io = \a -> do
val <- M.new 1
M.write val 0 a
return $ R val
_val :: R a -> IO a
_val = \ra -> M.read (val ra) 0
someFunctor :: Show a => (a -> b) -> IO (R a) -> IO (R b)
someFunctor = \f -> \ioA -> do
print "-- someFunctor"
val <- ioA >>= _val
print val --works 5
let ioB = io $ f val
--here, I want to actually `print val` when `f == print`
return $ f val
ioB
Output
"-- someFunctor"
5
"done"
The current sample code woks without errors, and what I want to achieve is to evaluate
f val
where
f val is the value wrapped into the new container ioB: io $ f val
However, due to the lazy-evaluation strategy of Haskell or some other reason, when f == print, this is not actually performed, so the val is not printed against my expectation.
So far, I did return $ f val, but this does not work unlike the working print val.
Just f val in do thread doesn't go well because f can be id and in that case, it's not IO type. Type mismatch. The compiler smartly generates an error here thanksfully.
So, my question is what is the generic way to implement f val to be evaluated when f == print f :: a -> IO ()?
If you want to do IO, you have to admit you're doing IO.
someFunctor :: Show a => (a -> IO b) -> IO (R a) -> IO (R b)
someFunctor = \f -> \ioA -> do
{- ... -}
b <- f val
io b
You can lift non-IO functions to IO ones with return, as in
someFunctor (return . id)
I have a single monadic action called step that I would like to run recursively until it returns a Nothing value. The below code works, but I'm calling runState on every step. The solution I'm looking for would build up within the state monad then call runState once at the end.
I know my use of Maybe here screams "transformer", but I'm trying to get it to work without a transformer first.
testFn :: Int -> Maybe Int
testFn i = if i > 5 then Nothing else Just i
step :: State Int (Maybe Int)
step = do
i <- get
let i' = testFn i
put $ maybe i (1 +) i'
return i'
go :: Int -> Int -> Maybe Int
go s a = case runState step s of
(Nothing, _) -> Just a
(Just a', s') -> go s' a'
repl:
> go 0 0
Just 5
You can write a modifier that transforms a a -> State s (Maybe a) to a a -> State s a:
repeatM :: Monad m => (a -> m (Maybe a)) -> a -> m a
repeatM f = g
where g x = f x >>= maybe (pure x) g
We can thus create a function with:
repeatStep :: Int -> State Int Int
repeatStep = repeatM (const step)
Then go is just:
go :: Int -> Int -> (Int, Int)
go s a = runState (repeatStep a) s
Here the first item of the 2-tuple is the Int that is the last Just … output before it outputs Nothing. The second item of 2-tuple is the state in that case.
and then our go thus returns:
Prelude Control.Monad.State> go 0 0
(5,6)
How can we prove that the continuation monad has no valid instance of MonadFix?
Well actually, it's not that there can't be a MonadFix instance, just that the library's type is a bit too constrained. If you define ContT over all possible rs, then not only does MonadFix become possible, but all instances up to Monad require nothing of the underlying functor :
newtype ContT m a = ContT { runContT :: forall r. (a -> m r) -> m r }
instance Functor (ContT m) where
fmap f (ContT k) = ContT (\kb -> k (kb . f))
instance Monad (ContT m) where
return a = ContT ($a)
join (ContT kk) = ContT (\ka -> kk (\(ContT k) -> k ka))
instance MonadFix m => MonadFix (ContT m) where
mfix f = ContT (\ka -> mfixing (\a -> runContT (f a) ka<&>(,a)))
where mfixing f = fst <$> mfix (\ ~(_,a) -> f a )
Consider the type signature of mfix for the continuation monad.
(a -> ContT r m a) -> ContT r m a
-- expand the newtype
(a -> (a -> m r) -> m r) -> (a -> m r) -> m r
Here's the proof that there's no pure inhabitant of this type.
---------------------------------------------
(a -> (a -> m r) -> m r) -> (a -> m r) -> m r
introduce f, k
f :: a -> (a -> m r) -> m r
k :: a -> m r
---------------------------
m r
apply k
f :: a -> (a -> m r) -> m r
k :: a -> m r
---------------------------
a
dead end, backtrack
f :: a -> (a -> m r) -> m r
k :: a -> m r
---------------------------
m r
apply f
f :: a -> (a -> m r) -> m r f :: a -> (a -> m r) -> m r
k :: a -> m r k :: a -> m r
--------------------------- ---------------------------
a a -> m r
dead end reflexivity k
As you can see the problem is that both f and k expect a value of type a as an input. However, there's no way to conjure a value of type a. Hence, there's no pure inhabitant of mfix for the continuation monad.
Note that you can't define mfix recursively either because mfix f k = mfix ? ? would lead to an infinite regress since there's no base case. And, we can't define mfix f k = f ? ? or mfix f k = k ? because even with recursion there's no way to conjure a value of type a.
But, could we have an impure implementation of mfix for the continuation monad? Consider the following.
import Control.Concurrent.MVar
import Control.Monad.Cont
import Control.Monad.Fix
import System.IO.Unsafe
instance MonadFix (ContT r m) where
mfix f = ContT $ \k -> unsafePerformIO $ do
m <- newEmptyMVar
x <- unsafeInterleaveIO (readMVar m)
return . runContT (f x) $ \x' -> unsafePerformIO $ do
putMVar m x'
return (k x')
The question that arises is how to apply f to x'. Normally, we'd do this using a recursive let expression, i.e. let x' = f x'. However, x' is not the return value of f. Instead, the continuation given to f is applied to x'. To solve this conundrum, we create an empty mutable variable m, lazily read its value x, and apply f to x. It's safe to do so because f must not be strict in its argument. When f eventually calls the continuation given to it, we store the result x' in m and apply the continuation k to x'. Thus, when we finally evaluate x we get the result x'.
The above implementation of mfix for the continuation monad looks a lot like the implementation of mfix for the IO monad.
import Control.Concurrent.MVar
import Control.Monad.Fix
instance MonadFix IO where
mfix f = do
m <- newEmptyMVar
x <- unsafeInterleaveIO (takeMVar m)
x' <- f x
putMVar m x'
return x'
Note, that in the implementation of mfix for the continuation monad we used readMVar whereas in the implementation of mfix for the IO monad we used takeMVar. This is because, the continuation given to f can be called multiple times. However, we only want to store the result given to the first callback. Using readMVar instead of takeMVar ensures that the mutable variable remains full. Hence, if the continuation is called more than once then the second callback will block indefinitely on the putMVar operation.
However, only storing the result of the first callback seems kind of arbitrary. So, here's an implementation of mfix for the continuation monad that allows the provided continuation to be called multiple times. I wrote it in JavaScript because I couldn't get it to play nicely with laziness in Haskell.
// mfix :: (Thunk a -> ContT r m a) -> ContT r m a
const mfix = f => k => {
const ys = [];
return (function iteration(n) {
let i = 0, x;
return f(() => {
if (i > n) return x;
throw new ReferenceError("x is not defined");
})(y => {
const j = i++;
if (j === n) {
ys[j] = k(x = y);
iteration(i);
}
return ys[j];
});
}(0));
};
const example = triple => k => [
{ a: () => 1, b: () => 2, c: () => triple().a() + triple().b() },
{ a: () => 2, b: () => triple().c() - triple().a(), c: () => 5 },
{ a: () => triple().c() - triple().b(), b: () => 5, c: () => 8 },
].flatMap(k);
const result = mfix(example)(({ a, b, c }) => [{ a: a(), b: b(), c: c() }]);
console.log(result);
Here's the equivalent Haskell code, sans the implementation of mfix.
import Control.Monad.Cont
import Control.Monad.Fix
data Triple = { a :: Int, b :: Int, c :: Int } deriving Show
example :: Triple -> ContT r [] Triple
example triple = ContT $ \k ->
[ Triple 1 2 (a triple + b triple)
, Triple 2 (c triple - a triple) 5
, Triple (c triple - b triple) 5 8
] >>= k
result :: [Triple]
result = runContT (mfix example) pure
main :: IO ()
main = print result
Notice that this looks a lot like the list monad.
import Control.Monad.Fix
data Triple = { a :: Int, b :: Int, c :: Int } deriving Show
example :: Triple -> [Triple]
example triple =
[ Triple 1 2 (a triple + b triple)
, Triple 2 (c triple - a triple) 5
, Triple (c triple - b triple) 5 8
]
result :: [Triple]
result = mfix example
main :: IO ()
main = print result
This makes sense because after all the continuation monad is the mother of all monads. I'll leave the verification of the MonadFix laws of my JavaScript implementation of mfix as an exercise for the reader.
Is there some way to write a function f :: (a -> b -> ... -> t) -> (Monad m => m a -> m b -> ... -> m t), basically liftMn for any n?
(EDIT: fixed nonsensical example.)
I'm writing an FRP library, and thought it'd be neat if I could have code vaguely like:
main = do
input1 <- signalFromTextBoxTheUserMayTypeANumberInto
input2 <- signalFromAnotherTextBox
divided <- signal div input1 input2
signal (\x -> showTextAlert ("input1 `div` input2 is " ++ show x)) divided
I've been fiddling with type families to get it working, but I'm starting to think that it's actually not doable. I'm currently doing something like this:
type Action a = IORef a -> IO ()
type Listener = IO ()
newtype Signal a = Signal (IORef (SigData a))
data SigData a = SigData {
trigger :: Action a,
output :: IORef a,
listeners :: [Listener]
}
class Sig a where
type S a
mkSig :: [AnySignal] -> a -> S a
instance Sig b => Sig (a -> b) where
type S (a -> b) = Signal a -> S b
mkSig dependencies f =
\s#(Signal sig) ->
let x = unsafePerformIO $ readIORef sig >>= readIORef . output
in mkSig (AnySignal s : dependencies) (f x)
instance Sig Int where
type S Int = IO (Signal Int)
out <- newIORef x
self <- Signal <$> (newIORef $ SigData {
trigger = \ref -> writeIORef ref $! x,
output = out,
listeners = []
})
mapM_ (self `listensTo`) deps
return self
This obviously doesn't work, as the unsafePerformIO gets evaluated once and then keeps that value, and if did work it'd still be ugly, hacky and generally evil. Is there a way to do this, or will I just have to let go of the idea?
I'm kind of new to all of this, so forgive me if this is a silly answer, but isn't this exactly what applicative functors are for?
Applicatives let you do something like:
f :: a -> b -> ... -> c
f2 :: Applicative p => p a -> p b ... -> p c
f2 x ... y = f <$> x <*> ... <*> y
if I'm not mistaken. (The ellipses are any number of types/arguments)
How about the Strathclyde Haskell Environment preprocessor, which lets you use idiom brackets, the original notation for applicative functors? This lets you use (| f a b c |) for f <$> a <*> b <*> c. Your example would be (| input1 `div` input2 |).
By the way, it's probably a bad idea for your Signal type to have a Monad instance; this causes the well-known (in the FRP community) problem of time leaks; see this blog post for more information. An Applicative interface is OK, but a Monad interface is not. There are several solutions that prevent time leaks while still allowing the same dynamic event switching behaviour, involving things like an additional type parameter or another monad (as seen in, e.g. the sodium library).
I am looking for a monad transformer that can be used to track the progress of a procedure. To explain how it would be used, consider the following code:
procedure :: ProgressT IO ()
procedure = task "Print some lines" 3 $ do
liftIO $ putStrLn "line1"
step
task "Print a complicated line" 2 $ do
liftIO $ putStr "li"
step
liftIO $ putStrLn "ne2"
step
liftIO $ putStrLn "line3"
-- Wraps an action in a task
task :: Monad m
=> String -- Name of task
-> Int -- Number of steps to complete task
-> ProgressT m a -- Action performing the task
-> ProgressT m a
-- Marks one step of the current task as completed
step :: Monad m => ProgressT m ()
I realize that step has to exist explicitly because of the monadic laws, and that task has to have an explicit step number parameter because of program determinism/the halting problem.
The monad as described above could, as I see it, be implemented in one of two ways:
Via a function that would return the current task name/step index stack, and a continuation in the procedure at the point that it left off. Calling this function repeatedly on the returned continuation would complete the execution of the procedure.
Via a function that took an action describing what to do when a task step has been completed. The procedure would run uncontrollably until it completed, "notifying" the environment about changes via the provided action.
For solution (1), I have looked at Control.Monad.Coroutine with the Yield suspension functor. For solution (2), I don't know of any already available monad transformers that would be useful.
The solution I'm looking for should not have too much performance overhead and allow as much control over the procedure as possible (e.g. not require IO access or something).
Do one of these solutions sound viable, or are there other solutions to this problem somewhere already? Has this problem already been solved with a monad transformer that I've been unable to find?
EDIT: The goal isn't to check whether all the steps have been performed. The goal is to be able to "monitor" the process while it is running, so that one can tell how much of it has been completed.
This is my pessimistic solution to this problem. It uses Coroutines to suspend the computation on each step, which lets the user perform an arbitrary computation to report some progress.
EDIT: The full implementation of this solution can be found here.
Can this solution be improved?
First, how it is used:
-- The procedure that we want to run.
procedure :: ProgressT IO ()
procedure = task "Print some lines" 3 $ do
liftIO $ putStrLn "--> line 1"
step
task "Print a set of lines" 2 $ do
liftIO $ putStrLn "--> line 2.1"
step
liftIO $ putStrLn "--> line 2.2"
step
liftIO $ putStrLn "--> line 3"
main :: IO ()
main = runConsole procedure
-- A "progress reporter" that simply prints the task stack on each step
-- Note that the monad used for reporting, and the monad used in the procedure,
-- can be different.
runConsole :: ProgressT IO a -> IO a
runConsole proc = do
result <- runProgress proc
case result of
-- We stopped at a step:
Left (cont, stack) -> do
print stack -- Print the stack
runConsole cont -- Continue the procedure
-- We are done with the computation:
Right a -> return a
The above program outputs:
--> line 1
[Print some lines (1/3)]
--> line 2.1
[Print a set of lines (1/2),Print some lines (1/3)]
--> line 2.2
[Print a set of lines (2/2),Print some lines (1/3)]
[Print some lines (2/3)]
--> line 3
[Print some lines (3/3)]
The actual implementation (See this for a commented version):
type Progress l = ProgressT l Identity
runProgress :: Progress l a
-> Either (Progress l a, TaskStack l) a
runProgress = runIdentity . runProgressT
newtype ProgressT l m a =
ProgressT
{
procedure ::
Coroutine
(Yield (TaskStack l))
(StateT (TaskStack l) m) a
}
instance MonadTrans (ProgressT l) where
lift = ProgressT . lift . lift
instance Monad m => Monad (ProgressT l m) where
return = ProgressT . return
p >>= f = ProgressT (procedure p >>= procedure . f)
instance MonadIO m => MonadIO (ProgressT l m) where
liftIO = lift . liftIO
runProgressT :: Monad m
=> ProgressT l m a
-> m (Either (ProgressT l m a, TaskStack l) a)
runProgressT action = do
result <- evalStateT (resume . procedure $ action) []
return $ case result of
Left (Yield stack cont) -> Left (ProgressT cont, stack)
Right a -> Right a
type TaskStack l = [Task l]
data Task l =
Task
{ taskLabel :: l
, taskTotalSteps :: Word
, taskStep :: Word
} deriving (Show, Eq)
task :: Monad m
=> l
-> Word
-> ProgressT l m a
-> ProgressT l m a
task label steps action = ProgressT $ do
-- Add the task to the task stack
lift . modify $ pushTask newTask
-- Perform the procedure for the task
result <- procedure action
-- Insert an implicit step at the end of the task
procedure step
-- The task is completed, and is removed
lift . modify $ popTask
return result
where
newTask = Task label steps 0
pushTask = (:)
popTask = tail
step :: Monad m => ProgressT l m ()
step = ProgressT $ do
(current : tasks) <- lift get
let currentStep = taskStep current
nextStep = currentStep + 1
updatedTask = current { taskStep = nextStep }
updatedTasks = updatedTask : tasks
when (currentStep > taskTotalSteps current) $
fail "The task has already completed"
yield updatedTasks
lift . put $ updatedTasks
The most obvious way to do this is with StateT.
import Control.Monad.State
type ProgressT m a = StateT Int m a
step :: Monad m => ProgressT m ()
step = modify (subtract 1)
I'm not sure what you want the semantics of task to be, however...
edit to show how you'd do this with IO
step :: (Monad m, MonadIO m) => ProgressT m ()
step = do
modify (subtract 1)
s <- get
liftIO $ putStrLn $ "steps remaining: " ++ show s
Note that you'll need the MonadIO constraint to print the state. You can have a different sort of constraint if you need a different effect with the state (i.e. throw an exception if the number of steps goes below zero, or whatever).
Not sure if this is exactly what you want, but here is an implementation that enforces the correct number of steps and requires there to be zero steps left at the end. For simplicity, I'm using a monad instead of a monad transformer over IO. Note that I am not using the Prelude monad to do what I'm doing.
UPDATE:
Now can extract the number of remaining steps. Run the following with -XRebindableSyntax
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Test where
import Prelude hiding (Monad(..))
import qualified Prelude as Old (Monad(..))
-----------------------------------------------------------
data Z = Z
data S n = S
type Zero = Z
type One = S Zero
type Two = S One
type Three = S Two
type Four = S Three
-----------------------------------------------------------
class Peano n where
peano :: n
fromPeano :: n -> Integer
instance Peano Z where
peano = Z
fromPeano Z = 0
instance Peano (S Z) where
peano = S
fromPeano S = 1
instance Peano (S n) => Peano (S (S n)) where
peano = S
fromPeano s = n `seq` (n + 1)
where
prev :: S (S n) -> (S n)
prev S = S
n = fromPeano $ prev s
-----------------------------------------------------------
class (Peano s, Peano p) => Succ s p | s -> p where
instance Succ (S Z) Z where
instance Succ (S n) n => Succ (S (S n)) (S n) where
-----------------------------------------------------------
infixl 1 >>=, >>
class ParameterisedMonad m where
return :: a -> m s s a
(>>=) :: m s1 s2 t -> (t -> m s2 s3 a) -> m s1 s3 a
fail :: String -> m s1 s2 a
fail = error
(>>) :: ParameterisedMonad m => m s1 s2 t -> m s2 s3 a -> m s1 s3 a
x >> f = x >>= \_ -> f
-----------------------------------------------------------
newtype PIO p q a = PIO { runPIO :: IO a }
instance ParameterisedMonad PIO where
return = PIO . Old.return
PIO io >>= f = PIO $ (Old.>>=) io $ runPIO . f
-----------------------------------------------------------
data Progress p n a = Progress a
instance ParameterisedMonad Progress where
return = Progress
Progress x >>= f = let Progress y = f x in Progress y
runProgress :: Peano n => n -> Progress n Zero a -> a
runProgress _ (Progress x) = x
runProgress' :: Progress p Zero a -> a
runProgress' (Progress x) = x
task :: Peano n => n -> Progress n n ()
task _ = return ()
task' :: Peano n => Progress n n ()
task' = task peano
step :: Succ s n => Progress s n ()
step = Progress ()
stepsLeft :: Peano s2 => Progress s1 s2 a -> (a -> Integer -> Progress s2 s3 b) -> Progress s1 s3 b
stepsLeft prog f = prog >>= flip f (fromPeano $ getPeano prog)
where
getPeano :: Peano n => Progress s n a -> n
getPeano prog = peano
procedure1 :: Progress Three Zero String
procedure1 = do
task'
step
task (peano :: Two) -- any other Peano is a type error
--step -- uncommenting this is a type error
step -- commenting this is a type error
step
return "hello"
procedure2 :: (Succ two one, Succ one zero) => Progress two zero Integer
procedure2 = do
task'
step `stepsLeft` \_ n -> do
step
return n
main :: IO ()
main = runPIO $ do
PIO $ putStrLn $ runProgress' procedure1
PIO $ print $ runProgress (peano :: Four) $ do
n <- procedure2
n' <- procedure2
return (n, n')