I have a simulation library that uses the FFI wrapped in a monad M, carrying a context. All the foreign functions are pure, so I've decided to make the monad lazy, which is normally convenient for flow-control. I represent my simulation as a list of simulation-frames, that I can consume by either writing to a file, or by displaying the frame graphically.
simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame]
simulation [] frame = return [frame]
simulation (step:steps) frame
= step frame >>= fmap (frame:) . simulation steps
Each frame consists of a tuple of newtype-wrapped ForeignPtrs that I can lift to my Haskell representation with
lift :: Frame -> M HFrame
Since the time-steps in my simulation are quite short, I only want to look at every n frames, for which I use
takeEvery n l = foldr cons nil l 0 where
nil _ = []
cons x rest 0 = x : rest n
cons x rest n = rest (n-1)
So my code looks something like
main = consume
$ takeEvery n
$ runM
$ simulation steps initialFrame >>= mapM lift
Now, the problem is that as I increase n, a thunk builds up. I've tried a couple of different ways to try to strictly evaluate each frame in simulation, but I have yet to figure out how to do so. ForeignPtr doesn't appear to have a NFData instance, so I can't use deepseq, but all my attempts with seq, including using seq on each element in the tuple, have been without noticeable effect.
EDIT:
Upon request, I have included more specifics, that I initially excluded since I think they are probably mostly noise for this question.
The monad
newtype FT c a = FT (Context -> a)
instance Functor (FT c) where
fmap f (FT a) = FT (f.a)
instance Applicative (FT c) where
pure a = FT (\_ -> a)
(<*>) (FT a) (FT b) = FT (\c -> a c $ b c)
instance Monad (FT c) where
return = pure
(>>=) (FT a) f = FT (\c -> (\(FT b) -> b c) $ f $ a c)
runFTIn :: Context -> (forall c. FT c a) -> a
runFTIn context (FT a) = a context
runFTWith :: [ContextOption] -> (forall c. FT c a) -> a
runFTWith options a
= unsafePerformIO
$ getContext options >>= \c -> return $ runFTIn c a
runFT = runFTWith []
unsafeLiftFromIO :: (Context -> IO a) -> FT c a
unsafeLiftFromIO a = FT (\c -> unsafePerformIO $ a c)
All the foreign functions are lifted from IO with unsafeLiftFromIO
newtype Box c = Box (ForeignPtr RawBox)
newtype Coordinates c = Coordinates (ForeignPtr RawCoordinates)
type Frame c = (Box c, Coordinates c)
liftBox :: Box c -> FT c HBox
liftCoordinates :: Coordinates c -> FT c HCoordinates
liftFrame (box, coordinates) = do
box' <- liftBox box
coordinates' <- liftCoordinates coordinates
return (box', coordinates')
The steps themselves are supposed to be arbitrary (Frame c -> FT c (Frame c)), so strictness should preferably be in the higher level code.
EDIT2:
I have now tried to use Streamly, however the problem persists, so I think the issue really is finding a way to strictly evaluate ForeignPtrs.
current implementations:
import Streamly
import qualified Streamly.Prelude as S
import qualified Streamly.Internal.Data.Stream.Serial as Serial
takeEvery n = Serial.unfoldrM ((fmap.fmap) (\(h, t) -> (h, S.drop (n-1) t)) . S.uncons)
(#) = flip ($)
simulation
:: (IsStream t)
=> Frame c
-> t (FT c) (Frame c -> FT c (Frame c))
-> t (FT c) (Frame c)
simulation frame = S.scanlM' (#) frame
EDIT3:
To clarify the symptoms and how I have diagnosed the problem.
The library calls OpenCL functions running on a GPU. I am sure that the freeing of the pointers is handled correctly - the ForeignPtrs have the correct freeing functions, and memory use is independent of total number of steps as long as this number is larger than n. What I find is that memory use on the GPU is basically linearly correlated to n. The consumer I've been using for this testing is
import qualified Data.ByteString.Lazy as BL
import Data.Binary
import Data.Binary.Put
writeTrajectory fn = fmap (BL.writeFile fn . runPut) . S.foldr ((>>).putFrame) (pure ()) . serially
For my streamly implementation, and
writeTrajectory fn = BL.writeFile fn . runPut . MapM_ putFrame
For the original implementation. Both should consume the stream continuously. I've generated the steps for testing with replicate.
I am unsure of how to more precisely analyze the memory-use on the GPU. System memory use is not an issue here.
Update:
I am starting to think it's not a matter of strictness, but of GC-problems. The run-time system does not know the size of the memory allocated on the GPU and so does not know to collect the pointers, this is less of an issue when there is stuff going on CPU-side as well, as that will produce allocations too, activating the GC. This would explain the slightly non-determinstic memory usage, but linear correlation to n that I've seen. How too solve this nicely is another issue, but I suspect there will be a substantial overhaul to my code.
I think the issue really is finding a way to strictly evaluate ForeignPtrs
If that is really the issue, one way to do that is to change the second clause of simulation:
{-# LANGUAGE BangPatterns #-}
simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame]
simulation [] frame = return [frame]
simulation (step:steps) frame#(!_, !_) -- Evaluate both components of the pair
= step frame >>= fmap (frame:) . simulation steps
Related
I am currently exploring the possibility to use basic containers to give FRP networks more structure and by that to create more sophisticated event networks easier.
Note: I use ordrea but had the same problem with reactive-banana too, so I guess this problem is not specific to the chosen frp implementation.
In this special case I am using a simple Matrix to store Events:
newtype Matrix (w :: Nat) (h :: Nat) v a where
Matrix :: Vector a -> Matrix w h v a
-- deriving instances: Functor, Foldable, Traversable, Applicative
Matrix is basically just a thin wrapper around Data.Vector and most functions I'll use are basically the same as the corresponding Vector ones. The notable exception is indexing, but that should be self explanatory.
With this I can define matrices of events like Matrix 10 10 (Event Double) and are able to define basic convolution algorithms on that:
applyStencil :: (KnownNat w, KnownNat h, KnownNat w', KnownNat h')
=> M.Matrix w' h' (a -> c)
-> M.Matrix w h (Event a)
-> M.Matrix w h (Event c)
applyStencil s m = M.generate stencil
where stencil x y = fold $ M.imap (sub x y) s
sub x0 y0 x y g = g <$> M.clampedIndex m (x0 - halfW + x) (y0 - halfH + y)
halfW = M.width s `div` 2
halfH = M.height s `div` 2
Notes:
M.generate :: (Int -> Int -> a) -> M.Matrix w h a and
M.imap :: (Int -> Int -> a -> b) -> M.Matrix w h a -> M.Matrix w h b
are just wrappers around Vector.generate and Vector.imap respectively.
M.clampedIndex clamps indices into the bounds of the matrix.
Event is an instance of Monoid which is why it is possible to just fold the Matrix w' h' (Event c) returned by M.imap (sub x y) s.
I have a setup approximately like this:
let network = do
-- inputs triggered from external events
let inputs :: M.Matrix 128 128 (Event Double)
-- stencil used:
let stencil :: M.Matrix 3 3 (Double -> Double)
stencil = fmap ((*) . (/16)) $ M.fromList [1,2,1,2,4,2,1,2,1]
-- convolute matrix by applying stencil
let convoluted = applyStencil stencil inputs
-- collect events in order to display them later
-- type: M.Matrix 128 128 (Behavior [Double])
let behaviors = fmap eventToBehavior convoluted
-- now there is a neat trick you can play because Matrix
-- is Traversable and Behaviors are Applicative:
-- type: Behavior (Matrix 128 128 [Double])
return $ Data.Traversable.sequenceA behaviors
Using something like this I am triggering ~15kEvents/s with no problems and lots of headroom in that regard.
Problem is that as soon as I sample the network I can only get about two samples per second from it:
main :: IO ()
main = do
-- initialize the network
sample <- start network
forever $ do
-- not all of the 128*128 inputs are triggered each "frame"
triggerInputs
-- sample the network
mat <- sample
-- display the matrix somehow (actually with gloss)
displayMatrix mat
So far I have made the following observations:
Profiling tells me that productivity is very low (4%-8%)
Most of the time is spend by the garbage collector in Gen 1 (~95%)
Data.Matrix.foldMap (ie fold) is allocating the most memory (~45%, as per -p)
When I was still working with reactive-banana Heinrich Apfelmus recommended that tree based traversals are a better fit for behaviors¹. I tried that for sequenceA, fold and traverse with no success.
I suspected that the newtype wrapper was preventing vectors fusion rules to fire². This is most likely not the culprit.
At this point I have spent the better part of the week searching for a solution to this problem. Intuitively I'd say that sampling should be much faster and and foldMap should not create so much garbage memory. Any ideas?
As a Java person learning Haskell I was getting use to the new way of thinking about everything but I've spent half a day trying to implement something with a simple RNG and am getting nowhere. In Java I could crate a static RNG and call it with Classname.random.nextInt(10) and it would meet these criteria:
I wouldn't have to keep a reference to the RNG and I could call it ad-hoc (even from inside a loop or a recursive function)
It would produce a new random number every time it was called
It would produce a new set of random numbers every time the project executed
So far in Haskell I'm facing the classic programmers dilemma - I can have 2/3. I'm still learning and have absolutely no idea about Monads, except that they might be able to help me here.
My Most recent attempt has been this:
getRn :: (RandomGen g) => Int -> Int -> Rand g Int
getRn lo hi= getRandomR (lo,hi)
--EDIT: Trimming my questions so that it's not so long winded, replacing with a summary and then what I ended up doing instead:
After creating a bunch of random cities (for TSP), I maped over them with a function createEdges that took a city and connected it to the rest of the cities: M.mapWithKey (\x y -> (x,(createEdges y [1..3] makeCountry)))
PROBLEM:
I wanted to replace [1..3] with something random. I.e. I wanted to map randomness (IO) over pure code. This caused no end of confusion for me (see people's attempt to answer me below to get a good sense of my confusion). In fact I'm still not even sure if I'm explaining the problem correctly.
I was getting this type of error: Couldn't match expected type [Int] with actual type IO [Int]
SOLUTION:
So after finding out that what I wanted to do was fundamentally wrong in a functional environment, I decided to change my approach. Instead of generating a list of cities and then applying randomness to connect them, I instead created an [[Int]] where each inner list represented the random edges. Thereby creating my randomness at the start of the process, rather than trying to map randomness over the pure code.
(I posted the final result as my own answer, but SO won't let me accept my own answer yet. Once it does I've reached that threshold I'll come back and accept)
You can work with random numbers without any monads or IO at all if you like.
All you have to know is, that as there is state (internal state of the random-number-generator) involved you have to take this state with you.
In my opinion the easiest framework for this is Sytem.Random.
Using this your getRn function could look like this:
getRn :: (RandomGen g) => Int -> Int -> g -> (Int, g)
getRn lo hi g = randomR (lo,hi) g
here you can view g as the state I mentioned above - you put it in and you get another back like this (in ghci):
> let init = mkStdGen 11
> let (myNr, nextGen) = getRn 1 6 init
> myNr
6
> let (myNr, nextGen') = getRn 1 6 nextGen
> myNr
4
I think you can start by using just this - thread the gen around and later when you get all the monad stuff come back and make it a bit easier to write/read.
I don't know the definitions of your data but here is a simple example that uses this technique:
module StackOQuestion where
import System.Random
getRn :: (RandomGen g) => Int -> Int -> g -> (Int, g)
getRn lo hi = randomR (lo,hi)
getRnList :: (RandomGen g) => (g -> (a, g)) -> Int -> g -> ([a], g)
getRnList f n g
| n <= 0 = ([], g)
| otherwise = let (ls, g') = getRnList f (n-1) g
(a, g'') = f g'
in (a:ls, g'')
type City = (Int, Int)
randomCity :: (RandomGen g) => g -> (City, g)
randomCity g =
let (f, g') = getRn 1 6 g
(s, g'') = getRn 1 6 g'
in ((f, s), g'')
randomCities :: (RandomGen g) => (Int, Int) -> g -> ([City], g)
randomCities (minC, maxC) g =
let (count, g') = getRn minC maxC g
in getRnList randomCity count g'
and you can test it like this:
> let init = mkStdGen 23
> randomCities (2,6) init
([(4,3),(1,2)],394128088 652912057)
As you can see this creates two Cities (here simply represented as an integer-pair) - for other values of init you will get other answers.
If you look the right way at this you can see that there is already the beginning of a state-monad there (the g -> ('a, g) part) ;)
PS: mkStdGen is a bit like the Random-initialization you know from Java and co (the part where you usually put your system-clock's tick-count in) - I choose 11 because it was quick to type ;) - of course you will always get the same numbers if you stick with 11 - so you will need to initialize this with something from IO - but you can push this pack to main and keep pure otherwise if you just pass then g around
I would say if you want to work with random numbers, the easiest thing to do is to use an utility library like Control.Monad.Random.
The more educational, work intensive path is to learn to write your own monad like that. First you want to understand the State monad and get comfortable with it. I think studying this older question (disclaimer: I have an answer there) may be a good starting point for studying this. The next step I would take is to be able to write the State monad on my own.
After that, the next exercise I would try is to write a "utility" monad for random number generation. By "utility" monad what I mean is a monad that basically repackages the standard State monad with an API that makes it easier for that specific task. This is how that Control.Monad.Random package is implemented:
-- | A monad transformer which adds a random number generator to an
-- existing monad.
newtype RandT g m a = RandT (StateT g m a)
Their RandT monad is really just a newtype definition that reuses StateT and adds a few utility functions so that you can concentrate on using random numbers rather than on the state monad itself. So for this exercise, you basically design a random number generation monad with the API you'd like to have, then use the State and Random libraries to implement it.
Edit: After a lot more reading and some extra help from a friend, I finally reduced it to this solution. However I'll keep my original solution in the answer as well just in case the same approach helps another newbie like me (it was a vital part of my learning process as well).
-- Use a unique random generator (replace <$> newStdGen with mkStdGen 123 for testing)
generateTemplate = createCitiesWeighted <$> newStdGen
-- create random edges (with weight as pair) by taking a random sized sample of randoms
multiTakePair :: [Int] -> [Int] -> [Int] -> [[(Int,Int)]]
multiTakePair ws (l:ls) is = (zip chunka chunkb) : multiTakePair remaindera ls remainderb
where
(chunkb,remainderb) = splitAt l is
(chunka,remaindera) = splitAt l ws
-- pure version of utilizing multitake by passing around an RNG using "split"
createCitiesWeighted :: StdGen -> [[(Int,Int)]]
createCitiesWeighted gen = take count result
where
(count,g1) = randomR (15,20) gen
(g2,g3) = split g1
cs = randomRs (0, count - 2) g1
es = randomRs (3,7) g2
ws = randomRs (1,10) g3
result = multiTakePair ws es cs
The original solution -----
As well as #user2407038's insightful comments, my solution relied very heavily on what I read from these two questions:
Sampling sequences of random numbers in Haskell
Random Integer in Haskell
(NB. I was having an issue where I couldn't work out how to randomize how many edges each city would have, #AnrewC provided an awesome response that not only answered that question but massively reduce excess code)
module TspRandom (
generateCityTemplate
) where
import Control.Monad (liftM, liftM2) -- promote a pure function to a monad
-- #AndrewC's suggestion
multiTake :: [Int] -> [Int] -> [[Int]]
multiTake (l:ls) is = chunk : multiTake ls remainder
where (chunk,remainder) = splitAt l is
-- Create a list [[Int]] where each inner int is of a random size (3-7)
-- The values inside each inner list max out at 19 (total - 1)
createCities = liftM (take 20) $ liftM2 multiTake (getRandomRs (3,7)) (getRandomRs (0, 19))
-- Run the generator
generateCityTemplate = do
putStrLn "Calculating # Cities"
x <- createCities
print x
return ()
The state monad is actually very simple. It is just a function from a state to a value and a new state, or:
data State s a = State {getState :: s -> (s, a)}
In fact, this is exactly what the Rand monad is. It isn't necessary to understand the mechanics of State to use Rand. You shouldn't be evaluating the Rand inside of IO, just use it directly, using the same do notation you have been using for IO. do notation works for any monad.
createCities :: Rand StdGen Int
createCities = getRn minCities maxCities
x :: Cities -> X
x = ...
func :: Rand StdGen X
func = do
cities <- createCities
return (x cities)
-- also valid
func = cities <$> createCities
func = createCities >>= return . x
You can't write getConnections like you have written it. You must do the following:
getConnections :: City -> Country -> Rand StdGen [Int]
getConnections c country = do
edgeCount <- createEdgeCount
fromIndecies [] edgeCount (citiesExcludeSelf c country)
Any function which calls getConnections will have to also return a value of type Rand StdGen x. You can only get rid of it once you have written the entire algorithm and want to run it.
Then, you can run the result using evalRandIO func, or, if you want to test some algorithm and you want to give it the same inputs on every test, you can use evalRand func (mkStdGen 12345), where 12345, or any other number, is your seed value.
Sometimes it is necessary to perform some complex routines in order to retrieve or save data, which is being processed. In this case one wants to separate data generation and data processing logic. The common way is to use iteratee-like functionality. There are lots of decent libraries: pipes, conduit, etc. In most cases they will do the thing. But AFAIK they are (except, maybe, pipes) limited by the order of processing.
But consider a log viewer example: human may desire to ramble back and forth randomly. He also may zoom in and out. I fear iteratees can't help here.
A straightforward solution may look like this:
-- True is for 'right', 'up', etc. and vice versa
type Direction = Bool
class Frame (f :: * -> *) where
type Dimension f :: *
type Origin f :: * -> *
grow', shrink' move' :: Monad m => Dimension f -> Direction -> f a -> m (f a)
move' dim dir f = grow' dim dir f >>= shrink' dim (not dir)
liftF' :: (Origin f a -> b) -> f a -> b
class Frame f => MFrame f where
liftMF' :: (Origin f a -> (b, Origin f a)) -> f a -> (b, f a)
-- Example instance: infinite stream.
data LF a = LF [a] [a] [a]
instance Frame LF where
type Dimension LF = () -- We have only one dimension to move in...
type Origin LF = [] -- User see piece of stream as a plain list
liftF' f (LF _ m _) = f m
grow' () True (LF l m (h:r)) = return $ LF l (m++[h]) r
...
Then one may wrap this into StateT and so on. So, the questions:
0) Did I miss the point of iteratees completely, and they are applicable here?
1) Did I just reinvent a well-known wheel?
2) It is obvious, that grow and shrink operations are pretty uneffective, as their complexity is proportional to the frame size. Is there a better way to extend zippers like this?
You want lenses, specifically the sequenceOf function. Here is an example of targeted loading of a 3-tuple:
sequenceOf _2 :: (IO a, IO b, IO c) -> IO (IO a, b, IO c)
sequenceOf takes a lens to a polymorphic field that contains a loading action, runs the action, then replaces the field with the result of the action. You can use sequenceOf on your own custom types by just making your type polymorphic in the fields you want to load, like this:
data Asset a b = Asset
{ _art :: a
, _sound :: b
}
... and also making your lenses use the full four type parameters (this is one reason why they exist):
art :: Lens (Asset a1 b) (Asset a2 b) a1 a2
art k (Asset x y) = fmap (\x' -> Asset x' y) (k x)
sound :: Lens (Asset a b1) (Asset a b2) b1 b2
sound k (Asset x y) = fmap (\y' -> Asset x y') (k y)
... or you can auto generate lenses using makeLenses and they will be sufficiently general.
Then you can just write:
sequenceOf art :: Asset (IO Art) b -> IO (Asset Art b)
... and loading multiple assets is as simple as composing Kleisli arrows::
sequenceOf art >=> sequenceOf sound
:: Asset (IO Art) (IO Sound) -> IO (Asset Art Sound)
... and of course you can nest assets and compose lenses to reach nested assets and everything still "just works".
Now you have a pure Asset type that you can process using pure functions, and all the loading logic is factored out into lenses.
I wrote this on my phone so there may be several errors, but I will fix them later.
I'm using haskell to implement a pattern involving functions that return a value, and themselves (or a function of the same type). Right now I've implemented this like so:
newtype R a = R (a , a -> R a)
-- some toy functions to demonstrate
alpha :: String -> R String
alpha str
| str == reverse str = R (str , omega)
| otherwise = R (reverse str , alpha)
omega :: String -> R String
omega (s:t:r)
| s == t = R (s:t:r , alpha)
| otherwise = R (s:s:t:r , omega)
The driving force for these types of functions is a function called cascade:
cascade :: (a -> R a) -> [a] -> [a]
cascade _ [] = []
cascade f (l:ls) = el : cascade g ls where
R (el , g) = f l
Which takes a seed function and a list, and returns a list created by applying the seed function to the first element of the list, applying the function returned by that to the second element of the list, and so on and so forth.
This works--however, in the process of using this for slightly more useful things, I noticed that a lot of times I had the basic units of which are functions that returned functions other than themselves only rarely; and explicitly declaring a function to return itself was becoming somewhat tedious. I'd rather be able to use something like a Monad's return function, however, I have no idea what bind would do for functions of these types, especially since I never intended these to be linked with anything other than the function they return in the first place.
Trying to shoehorn this into a Monad started worrying me about whether or not what I was doing was useful, so, in short, what I want to know is:
Is what I'm doing a Bad Thing? if not,
Has what I'm doing been done before/am I reinventing the wheel here? if not,
Is there an elegant way to do this, or have I already reached this and am being greedy by wanting some kind of return analogue?
(Incidentally, besides, 'functions that return themeselves' or 'recursive data structure (of functions)', I'm not quite sure what this kind of pattern is called, and has made trying to do effective research in it difficult--if anyone could give me a name for this pattern (if it indeed has one), that alone would be very helpful)
As a high-level consideration, I'd say that your type represents a stateful stream transformer. What's a bit confusing here is that your type is defined as
newtype R a = R (a , a -> R a)
instead of
newtype R a = R (a -> (R a, a))
which would be a bit more natural in the streaming context because you typically don't "produce" something if you haven't received anything yet. Your functions would then have simpler types too:
alpha, omage :: R String
cascade :: R a -> [a] -> [a]
If we try to generalize this idea of a stream transformer, we soon realize that the case where we transform a list of as into a list of as is just a special case. With the proper infrastructure in place we could just as well produce a list of bs. So we try to generalize the type R:
newtype R a b = R (a -> (R a b, b))
I've seen this kind of structure being called a Circuit, which happens to be a full-blown arrow. Arrows are a generalization of the concept of functions and are an even more powerful construct than monads. I can't pretend to understand the category-theoretical background, but it's definitely interesting to play with them. For example, the trivial transformation is just Cat.id:
import Control.Category
import Control.Arrow
import Prelude hiding ((.), id)
import qualified Data.List as L
-- ... Definition of Circuit and instances
cascade :: Circuit a b -> [a] -> [b]
cascade cir = snd . L.mapAccumL unCircuit cir
--
ghci> cascade (Cat.id) [1,2,3,4]
[1,2,3,4]
We can also simulate state by parameterizing the circuit we return as the continuation:
countingCircuit :: (a -> b) -> Circuit a (Int, b)
countingCircuit f = cir 0
where cir i = Circuit $ \x -> (cir (i+1), (i, f x))
--
ghci> cascade (countingCircuit (+5)) [10,3,2,11]
[(0,15),(1,8),(2,7),(3,16)]
And the fact that our circuit type is a category gives us a nice way to compose circuits:
ghci> cascade (countingCircuit (+5) . arr (*2)) [10,3,2,11]
[(0,25),(1,11),(2,9),(3,27)]
It looks like what you have is a simplified version of a stream. That is to
say, a representation of an infinite stream of values. I don't think you can
easily define this as a monad, because you use the same type for your seed as
for your elements, which makes defining fmap difficult (it seems that you
would need to invert the function provided to fmap so as to be able to
recover the seed). You can make this a monad by making the seed type
independent of the element type like so
{-# LANGUAGE ExistentialQuantification #-}
data Stream a = forall s. Stream a s (s -> Stream a)
This will allow you to define a Functor and Monad instance as follows
unfold :: (b -> (a, b)) -> b -> Stream a
unfold f b = Stream a b' (unfold f)
where (a, b') = f b
shead :: Stream a -> a
shead (Stream a _ _) = a
stail :: Stream a -> Stream a
stail (Stream _ b f) = f b
diag :: Stream (Stream a) -> Stream a
diag = unfold f
where f str = (shead $ shead str, stail $ fmap stail str)
sjoin :: Stream (Stream a) -> Stream a
sjoin = diag
instance Functor Stream where
fmap f (Stream a b g) = Stream (f a) b (fmap f . g)
instance Monad Stream where
return = unfold (\x -> (x, x))
xs >>= f = diag $ fmap f xs
Note that this only obeys the Monad laws when viewed as a set, as it does not
preserve element ordering.
This explanation
of the stream monad uses infinite lists, which works just as well in Haskell
since they can be generated in a lazy fashion. If you check out the
documentation for the Stream type in the vector library, you will
find a more complicated version, so that it can be used in efficient stream fusion.
I don't have much to add, except to note that your cascade function can be written as a left fold (and hence also as a right fold, though I haven't done the transformation.)
cascade f = reverse . fst . foldl func ([], f)
where
func (rs,g) s = let R (r,h) = g s in (r:rs,h)
I'm working on a Haskell project that involves tying a big knot: I'm parsing a serialized representation of a graph, where each node is at some offset into the file, and may reference another node by its offset. So I need to build up a map from offsets to nodes while parsing, which I can feed back to myself in a do rec block.
I have this working, and kinda-sorta-reasonably abstracted into a StateT-esque monad transformer:
{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving #-}
import qualified Control.Monad.State as S
data Knot s = Knot { past :: s, future :: s }
newtype RecStateT s m a = RecStateT (S.StateT (Knot s) m a) deriving
( Alternative
, Applicative
, Functor
, Monad
, MonadCont
, MonadError e
, MonadFix
, MonadIO
, MonadPlus
, MonadReader r
, MonadTrans
, MonadWriter w )
runRecStateT :: RecStateT s m a -> Knot s -> m (a, Knot s)
runRecStateT (RecStateT st) = S.runStateT st
tie :: MonadFix m => RecStateT s m a -> s -> m (a, s)
tie m s = do
rec (a, Knot s' _) <- runRecStateT m (Knot s s')
return (a, s')
get :: Monad m => RecStateT s m (Knot s)
get = RecStateT S.get
put :: Monad m => s -> RecStateT s m ()
put s = RecStateT $ S.modify $ \ ~(Knot _ s') -> Knot s s'
The tie function is where the magic happens: the call to runRecStateT produces a value and a state, which I feed it as its own future. Note that get allows you to read from both the past and future states, but put only allows you to modify the "present."
Question 1: Does this seem like a decent way to implement this knot-tying pattern in general? Or better still, has somebody implemented a general solution to this, that I overlooked when snooping through Hackage? I beat my head against the Cont monad for a while, since it seemed possibly more elegant (see similar post from Dan Burton), but I just couldn't work it out.
Totally subjective Question 2: I'm not totally thrilled with the way my calling code ends up looking:
do
Knot past future <- get
let {- ... -} = past
{- ... -} = future
node = {- ... -}
put $ {- ... -}
return node
Implementation details here omitted, obviously, the important point being that I have to get the past and future state, pattern-match them inside a let binding (or explicitly make the previous pattern lazy) to extract whatever I care about, then build my node, update my state and finally return the node. Seems unnecessarily verbose, and I particularly dislike how easy it is to accidentally make the pattern that extracts the past and future states strict. So, can anybody think of a nicer interface?
I've been playing around with stuff, and I think I've come up with something... interesting. I call it the "Seer" monad, and it provides (aside from Monad operations) two primitive operations:
see :: Monoid s => Seer s s
send :: Monoid s => s -> Seer s ()
and a run operation:
runSeer :: Monoid s => Seer s a -> a
The way this monad works is that see allows a seer to see everything, and send allows a seer to "send" information to all other seers for them to see. Whenever any seer performs the see operation, they are able to see all of the information that has been sent, and all of the information that will be sent. In other words, within a given run, see will always produce the same result no matter where or when you call it. Another way of saying it is that see is how you get a working reference to the "tied" knot.
This is actually very similar to just using fix, except that all of the sub-parts are added incrementally and implicitly, rather than explicitly. Obviously, seers will not work correctly in the presence of a paradox, and sufficient laziness is required. For example, see >>= send may cause an explosion of information, trapping you in a time loop.
A dumb example:
import Control.Seer
import qualified Data.Map as M
import Data.Map (Map, (!))
bar :: Seer (Map Int Char) String
bar = do
m <- see
send (M.singleton 1 $ succ (m ! 2))
send (M.singleton 2 'c')
return [m ! 1, m ! 2]
As I said, I've just been toying around, so I have no idea if this is any better than what you've got, or if it's any good at all! But it's nifty, and relevant, and if your "knot" state is a Monoid, then it just might be useful to you. Fair warning: I built Seer by using a Tardis.
https://github.com/DanBurton/tardis/blob/master/Control/Seer.hs
I wrote up an article on this topic at entitled Assembly: Circular Programming with Recursive do where I describe two methods for building an assembler using knot tying. Like your problem, an assembler has to be able to resolve address of labels that may occur later in the file.
Regarding the implementation, I would make it a composition of a Reader monad (for the future) and a State monad (for past/present). The reason is that you set your future only once (in tie) and then don't change it.
{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving #-}
import Control.Monad.State
import Control.Monad.Reader
import Control.Applicative
newtype RecStateT s m a = RecStateT (StateT s (ReaderT s m) a) deriving
( Alternative
, Applicative
, Functor
, Monad
, MonadPlus
)
tie :: MonadFix m => RecStateT s m a -> s -> m (a, s)
tie (RecStateT m) s = do
rec (a, s') <- flip runReaderT s' $ flip runStateT s m
return (a, s')
getPast :: Monad m => RecStateT s m s
getPast = RecStateT get
getFuture :: Monad m => RecStateT s m s
getFuture = RecStateT ask
putPresent :: Monad m => s -> RecStateT s m ()
putPresent = RecStateT . put
Regarding your second question, it'd help to know your dataflow (i.e. to have a minimal example of your code). It's not true that strict patterns always lead to loops. It's true that you need to be careful so as not to create a non-producing loop, but the exact restrictions depend on what and how you're building.
I had a similar problem recently, but I chose a different approach. A recursive data structure can be represented as a type fixed point on a data type functor. Loading data can be then split into two parts:
Load the data into a structure that references other nodes only by some kind of identifier. In the example it's Loader Int (NodeF Int), which constructs a map of values of type NodeF Int Int.
Tie the knot by creating a recursive data structure by replacing the identifiers with actual data. In the example the resulting data structures have type Fix (NodeF Int), and they are later converted to Node Int for convenience.
It's lacking a proper error handling etc., but the idea should be clear from that.
-- Public Domain
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
-- Fixed point operator on types and catamohism/anamorphism methods
-- for constructing/deconstructing them:
newtype Fix f = Fix { unfix :: f (Fix f) }
catam :: Functor f => (f a -> a) -> (Fix f -> a)
catam f = f . fmap (catam f) . unfix
anam :: Functor f => (a -> f a) -> (a -> Fix f)
anam f = Fix . fmap (anam f) . f
anam' :: Functor f => (a -> f a) -> (f a -> Fix f)
anam' f = Fix . fmap (anam f)
-- The loader itself
-- A representation of a loader. Type parameter 'k' represents the keys by
-- which the nodes are represented. Type parameter 'v' represents a functor
-- data type representing the values.
data Loader k v = Loader (Map k (v k))
-- | Creates an empty loader.
empty :: Loader k v
empty = Loader $ Map.empty
-- | Adds a new node into a loader.
update :: (Ord k) => k -> v k -> Loader k v -> Loader k v
update k v = update' k (const v)
-- | Modifies a node in a loader.
update' :: (Ord k) => k -> (Maybe (v k) -> (v k)) -> Loader k v -> Loader k v
update' k f (Loader m) = Loader $ Map.insertWith (const (f . Just)) k (f Nothing) $ m
-- | Does the actual knot-tying. Creates a new data structure
-- where the references to nodes are replaced by the actual data.
tie :: (Ord k, Functor v) => Loader k v -> Map k (Fix v)
tie (Loader m) = Map.map (anam' $ \k -> fromJust (Map.lookup k m)) m
-- -----------------------------------------------------------------
-- Usage example:
data NodeF n t = NodeF n [t]
instance Functor (NodeF n) where
fmap f (NodeF n xs) = NodeF n (map f xs)
-- A data structure isomorphic to Fix (NodeF n), but easier to work with.
data Node n = Node n [Node n]
deriving Show
-- The isomorphism that does the conversion.
nodeunfix :: Fix (NodeF n) -> Node n
nodeunfix = catam (\(NodeF n ts) -> Node n ts)
main :: IO ()
main = do
-- Each node description consist of an integer ID and a list of other nodes
-- it references.
let lss =
[ (1, [4])
, (2, [1])
, (3, [2, 1])
, (4, [3, 2, 1])
, (5, [5])
]
print lss
-- Fill a new loader with the data:
let
loader = foldr f empty lss
f (label, dependsOn) = update label (NodeF label dependsOn)
-- Tie the knot:
let tied' = tie loader
-- And convert Fix (NodeF n) into Node n:
let tied = Map.map nodeunfix tied'
-- For each node print the label of the first node it references
-- and the count of all referenced nodes.
print $ Map.map (\(Node n ls#((Node n1 _) : _)) -> (n1, length ls)) tied
I'm kind of overwhelmed by the amount of Monad usage.
I might not understand the past/future things, but I guess you are just trying to express the lazy+fixpoint binding. (Correct me if I'm wrong.)
The RWS Monad usage with R=W is kind of funny, but you do not need the State and the loop, when you can do the same with fmap. There is no point in using Monads if they do not make things easier. (Only very few Monads represent chronological order, anyway.)
My general solution to tying the knot:
I parse everything to a List of nodes,
convert that list to a Data.Vector for O(1) access to boxed (=lazy) values,
bind that result to a name using let or the fix or mfix function,
and access that named Vector inside the parser. (see 1.)
That example solution in your blog, where you write sth. like this:
data Node = Node {
value :: Int,
next :: Node
} deriving Show
…
tie = …
parse = …
data ParserState = …
…
example :: Node
example =
let (_, _, m) = tie parse $ ParserState 0 [(0, 1), (1, 2), (2, 0)]
in (m Map.! 0)
I would have written this way:
{-# LANGUAGE ViewPatterns, NamedFieldPuns #-}
import Data.Vector as Vector
example :: Node
example =
let node :: Int -> Node
node = (Vector.!) $ Vector.fromList $
[ Node{value,next}
| (value,node->next) <- [(0, 1), (1, 2), (2, 0)]
]
in (node 0)
or shorter:
{-# LANGUAGE ViewPatterns, NamedFieldPuns #-}
import Data.Vector as Vector
example :: Node
example = (\node->(Vector.fromList[ Node{value,next}
| (value,node->next) <- [(0, 1), (1, 2), (2, 0)]
] Vector.!)) `fix` 0