Unexpected caching behavior using polymorphic records in Haskell - haskell

I've run into some unexpected behavior using polymorphic records in Haskell, where some values are not cached when I expect them to be cached.
Here is a minimal example:
{-# LANGUAGE RankNTypes #-}
import Debug.Trace
-- Prints out two "hello"s
data Translation = Trans { m :: forall a . Floating a => a }
g :: Floating a => a -> a
g x = x + 1
f :: Floating a => a -> a
f x = trace "hello" $ x - 2.0
-- Only one "hello"
-- data Translation = Trans { m :: Float }
--
-- f :: Float -> Float
-- f x = trace "hello" $ x - 2.0
main :: IO ()
main = do
let trans = Trans { m = f 1.5 }
putStrLn $ show $ m trans
putStrLn $ show $ m trans
In the example, I thought if the value f 1.5 was computed and stored in the field m, on the next time it is accessed, it would not be computed again. However, it seems to be recomputed on every access to the record field, as shown by the fact that "hello" is printed twice.
On the other hand, if we remove the polymorphism from the field, the value is cached as expected, and "hello" is only printed once.
I suspect this is due to the interaction of typeclasses (being treated as records) preventing memoization. However, I don't fully understand why.
I realized that compiling with -O2 makes the problem go away, however, this behavior occurs in a much larger system where compiling with -O2 does not seem to have any effect, therefore I'd like to understand the root cause of the problem, so I can fix the performance issues in the larger system.

Hold my beer.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
import Debug.Trace
data Dict c where Dict :: c => Dict c
-- An isomorphism between explicit dictionary-passing style (Dict c -> a)
-- and typeclass constraints (c => a) exists:
from :: (c => a) -> (Dict c -> a)
from v Dict = v
to :: (Dict c -> a) -> (c => a)
to f = f Dict
data Translation = Trans { m :: forall a . Floating a => a }
f1, f2 :: Dict (Floating a) -> a -> a
f1 = trace "hello" $ \Dict x -> x - 2.0
f2 = \Dict -> trace "hello" $ \x -> x - 2.0
main = do
let trans1 = Trans { m = to (flip f1 1.5) }
trans2 = Trans { m = to (flip f2 1.5) }
putStrLn "trans1"
print (m trans1)
print (m trans1)
putStrLn "trans2"
print (m trans2)
print (m trans2)
Take a second to predict what this will output before you run it. Then go ask your GHC if she agrees with your guess.
Clear as mud?
The basic distinction you need to draw here is right here in this significantly simplified example:
> g = trace "a" $ \() -> trace "b" ()
> g ()
a
b
()
> g ()
b
()
There is a separate notion of caching a function and caching its output. The latter is, simply, never done in GHC (though see discussion of what's going on with your optimized version below). The former may sound dumb, but it in fact is not so dumb as you might think; you could imagine writing a function which is, say, id if the collatz conjecture is true and not otherwise. In such a situation, it makes complete sense to only test the collatz conjecture once, and then cache whether we should behave as id or not forever afterwards.
Once you understand this basic fact, the next leap you must believe is that in GHC, typeclass constraints are compiled to functions. (The arguments to the function are typeclass dictionaries telling how each of the typeclass' methods behave.) GHC itself manages constructing and passing these dictionaries around for you, and in most cases it's quite transparent to the user.
But the upshot of this compilation strategy is this: a polymorphic but typeclass-constrained type is a function even if it doesn't appear to have function arrows in it. That is,
f 1.5 :: Floating a => a
looks like a plain old value; but in fact it is a function which takes a Floating a dictionary and produces a value of type a. So any computations that go into computing the value a are redone afresh each time this function is applied (read: used at a specific monomorphic type) because, after all, the precise value chosen depends critically on how the typeclass' methods behave.
This leaves only the question of why optimizations changed things in your situation. There I believe what happened is called "specialization", in which the compiler will try to notice when polymorphic things get used at a statically-known monomorphic type and make a binding for that. It goes something like this:
-- starting point
main = do
let trans = \dict -> trace "hello" $ minus dict (fromRational dict (3%2)) (fromRational dict (2%1))
print (trans dictForDouble)
print (trans dictForDouble)
-- specialization
main = do
let trans = \dict -> trace "hello" $ minus dict (fromRational dict (3%2)) (fromRational dict (2%1))
let transForDouble = trans dictForDouble
print transForDouble
print transForDouble
-- inlining
main = do
let transForDouble = trace "hello" $ minus dictForDouble (fromRational dict (3%2)) (fromRational dictForDouble (2%1))
print transForDouble
print transForDouble
In this last one the function-ness is gone; it is "as if" GHC has cached the output of trans when applied to the dictionary dictForDouble. (If you compile with optimizations and -ddump-simpl you will see it goes even further, doing constant-propagation to turn the minus ... stuff into just D# -0.5##. Whew!)

{-# LANGUAGE RankNTypes #-}
import Debug.Trace
--Does not get cached
data Translation = Trans { m :: forall a. Floating a => a }
f :: Floating a => a -> a
f x = trace "f" $ x - 2.0
Since a is a rigid type variable bound by a type expected by the context
forall a. Floating a => a you would have to cache the context as well
--Does get cached
data Translation' = Trans' { m' :: Float }
f' :: Float -> Float
f' x = trace "f'" $ x - 2.0
Since this is a value of type Float it can be computed once and cached afterwards.
main :: IO ()
main = do
let
trans = Trans { m = f 1.5 }
trans' = Trans' { m' = f' 1.5}
putStrLn $ show $ (m trans :: Double)
putStrLn $ show $ (m trans :: Float)
-- ^ you can evaluate it with 2 different contexts
putStrLn $ show $ (m' trans' :: Float)
putStrLn $ show $ (m' trans' :: Float)
-- ^ context fixed
Note that the former one does not get cached whether compiler optimization is turned on or off.
When they are both Float and you turn on optimization the problem is gone.
If you compile the larger system with optimization and it is to inefficient on some metric I would suspect that the problem lies somewhere else.

Related

Point Free Style Required for Optimized Curry

Say we have a (contrived) function like so:
import Data.List (sort)
contrived :: Ord a => [a] -> [a] -> [a]
contrived a b = (sort a) ++ b
And we partially apply it to use elsewhere, eg:
map (contrived [3,2,1]) [[4],[5],[6]]
On the surface, this works as one would expect:
[[1,2,3,4],[1,2,3,5],[1,2,3,6]]
However, if we throw some traces in:
import Debug.Trace (trace)
contrived :: Ord a => [a] -> [a] -> [a]
contrived a b = (trace "sorted" $ sort a) ++ b
map (contrived $ trace "a value" [3,2,1]) [[4],[5],[6]]
We see that the first list passed into contrived is evaluated only once, but it is sorted for each item in [4,5,6]:
[sorted
a value
[1,2,3,4],sorted
[1,2,3,5],sorted
[1,2,3,6]]
Now, contrived can be rather simply translated to point-free style:
contrived :: Ord a => [a] -> [a] -> [a]
contrived a = (++) (sort a)
Which when partially applied:
map (contrived [3,2,1]) [4,5,6]
Still works as we expect:
[[1,2,3,4],[1,2,3,5],[1,2,3,6]]
But if we again add traces:
contrived :: Ord a => [a] -> [a] -> [a]
contrived a = (++) (trace "sorted" $ sort a)
map (contrived $ trace "a value" [3,2,1]) [[4],[5],[6]]
We see that now the first list passed into contrived is evaluated and sorted only once:
[sorted
a value
[1,2,3,4],[1,2,3,5],[1,2,3,6]]
Why is this so? Since the translation into pointfree style is so trivial, why can't GHC deduce that it only needs to sort a once in the first version of contrived?
Note: I know that for this rather trivial example, it's probably preferable to use pointfree style. This is a contrived example that I've simplified quite a bit. The real function that I'm having the issue with is less clear (in my opinion) when expressed in pointfree style:
realFunction a b = conditionOne && conditionTwo
where conditionOne = map (something a) b
conditionTwo = somethingElse a b
In pointfree style, this requires writing an ugly wrapper (both) around (&&):
realFunction a = both conditionOne conditionTwo
where conditionOne = map (something a)
conditionTwo = somethingElse a
both f g x = (f x) && (g x)
As an aside, I'm also not sure why the both wrapper works; the pointfree style of realFunction behaves like the pointfree style version of contrived in that the partial application is only evaluated once (ie. if something sorted a it would only do so once). It appears that since both is not pointfree, Haskell should have the same issue that it had with the non-pointfree contrived.
If I understand correctly, you are looking for this:
contrived :: Ord a => [a] -> [a] -> [a]
contrived a = let a' = sort a in \b -> a' ++ b
-- or ... in (a' ++)
If you want the sort to be computed only once, it has to be done before the \b.
You are correct in that a compiler could optimize this. This is known as the "full laziness" optimization.
If I remember correctly, GHC does not always do it because it's not always an actual optimization, in the general case. Consider the contrived example
foo :: Int -> Int -> Int
foo x y = let a = [1..x] in length a + y
When passing both arguments, the above code works in constant space: the list elements are immediately garbage collected as they are produced.
When partially applying x, the closure for foo x only requires O(1) memory, since the list is not yet generated. Code like
let f = foo 1000 in f 10 + f 20 -- (*)
still run in constant space.
Instead, if we wrote
foo :: Int -> Int -> Int
foo x = let a = [1..x] in (length a +)
then (*) would no longer run in constant space. The first call f 10 would allocate a 1000-long list, and keep it in memory for the second call f 20.
Note that your partial application
... = (++) (sort a)
essentially means
... = let a' = sort a in \b -> a' ++ b
since argument passing involves a binding, as in let. So, the result of your sort a is kept around for all the future calls.

Style vs Performance Using Vectors

Here's the code:
{-# LANGUAGE FlexibleContexts #-}
import Data.Int
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Generic as V
{-# NOINLINE f #-} -- Note the 'NO'
--f :: (Num r, V.Vector v r) => v r -> v r -> v r
--f :: (V.Vector v Int64) => v Int64 -> v Int64 -> v Int64
--f :: (U.Unbox r, Num r) => U.Vector r -> U.Vector r -> U.Vector r
f :: U.Vector Int64 -> U.Vector Int64 -> U.Vector Int64
f = V.zipWith (+) -- or U.zipWith, it doesn't make a difference
main = do
let iters = 100
dim = 221184
y = U.replicate dim 0 :: U.Vector Int64
let ans = iterate ((f y)) y !! iters
putStr $ (show $ U.sum ans)
I compiled with ghc 7.6.2 and -O2, and it took 1.7 seconds to run.
I tried several different versions of f:
f x = U.zipWith (+) x
f x = (U.zipWith (+) x) . id
f x y = U.zipWith (+) x y
Version 1 is the same as the original while versions 2 and 3 run in in under 0.09 seconds (and INLINING f doesn't change anything).
I also noticed that if I make f polymorphic (with any of the three signatures above), even with a "fast" definition (i.e. 2 or 3), it slows back down...to exactly 1.7 seconds. This makes me wonder if the original problem is perhaps due to (lack of) type inference, even though I'm explicitly giving the types for the Vector type and element type.
I'm also interested in adding integers modulo q:
newtype Zq q i = Zq {unZq :: i}
As when adding Int64s, if I write a function with every type specified,
h :: U.Vector (Zq Q17 Int64) -> U.Vector (Zq Q17 Int64) -> U.Vector (Zq Q17 Int64)
I get an order of magnitude better performance than if I leave any polymorphism
h :: (Modulus q) => U.Vector (Zq q Int64) -> U.Vector (Zq q Int64) -> U.Vector (Zq q Int64)
But I should at least be able to remove the specific phantom type! It should be compiled out, since I'm dealing with a newtype.
Here are my questions:
Where is the slowdown coming from?
What is going on in versions 2 and 3 of f that affect performance in any way? It seems like a bug to me that (what amounts to) coding style can affect performance like this. Are there other examples outside of Vector where partially applying a function or other stylistic choices affect performance?
Why does polymorphism slow me down an order of magnitude independent of where the polymorphism is (i.e. in the vector type, in the Num type, both, or phantom type)? I know polymorphism makes code slower, but this is ridiculous. Is there a hack around it?
EDIT 1
I filed a issue with the Vector library page. I found a GHC
issue relating to this problem.
EDIT2
I rewrote the question after gaining some insight from #kqr's answer.
Below is the original for reference.
--------------ORIGINAL QUESTION--------------------
Here's the code:
{-# LANGUAGE FlexibleContexts #-}
import Control.DeepSeq
import Data.Int
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Generic as V
{-# NOINLINE f #-} -- Note the 'NO'
--f :: (Num r, V.Vector v r) => v r -> v r -> v r
--f :: (V.Vector v Int64) => v Int64 -> v Int64 -> v Int64
--f :: (U.Unbox r, Num r) => U.Vector r -> U.Vector r -> U.Vector r
f :: U.Vector Int64 -> U.Vector Int64 -> U.Vector Int64
f = V.zipWith (+)
main = do
let iters = 100
dim = 221184
y = U.replicate dim 0 :: U.Vector Int64
let ans = iterate ((f y)) y !! iters
putStr $ (show $ U.sum ans)
I compiled with ghc 7.6.2 and -O2, and it took 1.7 seconds to run.
I tried several different versions of f:
f x = U.zipWith (+) x
f x = (U.zipWith (+) x) . U.force
f x = (U.zipWith (+) x) . Control.DeepSeq.force)
f x = (U.zipWith (+) x) . (\z -> z `seq` z)
f x = (U.zipWith (+) x) . id
f x y = U.zipWith (+) x y
Version 1 is the same as the original, version 2 runs in 0.111 seconds, and versions 3-6 run in in under 0.09 seconds (and INLINING f doesn't change anything).
So the order-of-magnitude slowdown appears to be due to laziness since force helped, but I'm not sure where the laziness is coming from. Unboxed types aren't allowed to be lazy, right?
I tried writing a strict version of iterate, thinking the vector itself must be lazy:
{-# INLINE iterate' #-}
iterate' :: (NFData a) => (a -> a) -> a -> [a]
iterate' f x = x `seq` x : iterate' f (f x)
but with the point-free version of f, this didn't help at all.
I also noticed something else, which could be just a coincidence and red herring:
If I make f polymorphic (with any of the three signatures above), even with a "fast" definition, it slows back down...to exactly 1.7 seconds. This makes me wonder if the original problem is perhaps due to (lack of) type inference, even though everything should be inferred nicely.
Here are my questions:
Where is the slowdown coming from?
Why does composing with force help, but using a strict iterate doesn't?
Why is U.force worse than DeepSeq.force? I have no idea what U.force is supposed to do, but it sounds a lot like DeepSeq.force, and seems to have a similar effect.
Why does polymorphism slow me down an order of magnitude independent of where the polymorphism is (i.e. in the vector type, in the Num type, or both)?
Why are versions 5 and 6, neither of which should have any strictness implications at all, just as fast as a strict function?
As #kqr pointed out, the problem doesn't seem to be strictness. So something about the way I write the function is causing the generic zipWith to be used rather than the Unboxed-specific version. Is this just a fluke between GHC and the Vector library, or is there something more general that can be said here?
While I don't have the definitive answer you want, there are two things that might help you along.
The first thing is that x `seq` x is, both semantically and computationally, the same thing as just x. The wiki says about seq:
A common misconception regarding seq is that seq x "evaluates" x. Well, sort of. seq doesn't evaluate anything just by virtue of existing in the source file, all it does is introduce an artificial data dependency of one value on another: when the result of seq is evaluated, the first argument must also (sort of; see below) be evaluated.
As an example, suppose x :: Integer, then seq x b behaves essentially like if x == 0 then b else b – unconditionally equal to b, but forcing x along the way. In particular, the expression x `seq` x is completely redundant, and always has exactly the same effect as just writing x.
What the first paragraph says is that writing seq a b doesn't mean that a will magically get evaluated this instant, it means that a will get evaluated as soon as b needs to be evaluated. This might occur later in the program, or maybe never at all. When you view it in that light, it is obvious that seq x x is a redundancy, because all it says is, "evaluate x as soon as x needs to be evaluated." Which of course is what would happen anyway if you had just written x.
This has two implications for you:
Your "strict" iterate' function isn't really any stricter than it would be without the seq. In fact, I have a hard time imagining how the iterate function could become any stricter than it already is. You can't make the tail of the list strict, because it is infinite. The main thing you can do is force the "accumulator", f x, but doing so doesn't give any significant performance increase on my system.[1]
Scratch that. Your strict iterate' does exactly the same thing as my bang pattern version. See the comments.
Writing (\z -> z `seq` z) does not give you a strict identity function, which I assume is what you were going for. In fact, the common identity function is as strict as you'll get – it will evaluate its result as soon as it is needed.
However, I peeked at the core GHC generates for
U.zipWith (+) y
and
U.zipWith (+) y . id
and there is only one big difference that my untrained eye can spot. The first one uses just a plain Data.Vector.Generic.zipWith (here's where your polymorphism coincidence might come into play – if GHC chooses a generic zipWith it will of course perform as if the code was polymorphic!) while the latter has exploded this single function call into almost 90 lines of state monad code and unpacked machine types.
The state monad code looks almost like the loops and destructive updates you would write in an imperative language, so I assume it's tailored pretty well to the machine it's running on. If I wasn't in such a hurry, I would take a longer look to see more exactly how it works and why GHC suddenly decided it needed a tight loop. I have attached the generated core as much for myself as anyone else who wants to take a look.[2]
[1]: Forcing the accumulator along the way: (This is what you already do, I misunderstood the code!)
{-# LANGUAGE BangPatterns #-}
iterate' f !x = x : iterate f (f x)
[2]: What core U.zipWith (+) y . id gets translated into.

Haskell's Scrap Your Boilerplate (SYB) - applying transformation only once instead of everywhere

What's the best way to apply a transformation to a tree only once instead of everywhere using SYB? For instance, in the following simplified expression, there are several instances of Var "x", and I want to replace the first instance with Var "y" only.
data Exp = Var String
| Val Int
| Plus Exp Exp
|...
myExp = Val 5 `Plus` Var "x" `Plus` Val 5 `Plus` Var "x" ...
This can't be done using the everywhere combinator since it will try to transform all instances of Var "x" to Var "y".
EDIT (after posting): Looks like somewhere is what I am looking for.
Being a SYB beginner myself, my answer is more like a guess, but seems to work.
Combinator somewhere recommended by Neil Brown probably doesn't do exactly what you want. It's defined as
-- | Apply a monadic transformation at least somewhere
somewhere :: MonadPlus m => GenericM m -> GenericM m
-- We try "f" in top-down manner, but descent into "x" when we fail
-- at the root of the term. The transformation fails if "f" fails
-- everywhere, say succeeds nowhere.
--
somewhere f x = f x `mplus` gmapMp (somewhere f) x
where
-- | Transformation of at least one immediate subterm does not fail
gmapMp :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
But we need to transform at most once. For this it seems that gmapMo will be better:
-- | Transformation of one immediate subterm with success
gmapMo :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
So I made my own combinator:
{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Data
import Data.Typeable (Typeable)
import Data.Generics.Schemes
import Data.Generics.Aliases
-- | Apply a monadic transformation once.
once :: MonadPlus m => GenericM m -> GenericM m
once f x = f x `mplus` gmapMo (once f) x
If the substitution fails, it returns mzero, otherwise it returns the substituted result. If you don't care if the substitution fails (no matches), you could use something like
once' :: (forall a. Data a => a -> Maybe a) -> (forall a. Data a => a -> a)
once' f x = fromMaybe x (once f x)
With these, we can do some replacements:
data Exp = Var String | Val Int | Plus Exp Exp
deriving (Show, Typeable, Data)
myExp = Val 5 `Plus` Var "x" `Plus` Val 5 `Plus` Var "x"
replM :: (MonadPlus m) => Exp -> m Exp
replM (Var "x") = return $ Var "y"
replM t = mzero
main = do
-- `somewhere` doesn't do what we want:
print $ (somewhere (mkMp replM) myExp :: Maybe Exp)
-- returns `Just ..` if the substitution succeeds once,
-- Nothing otherwise.
print $ (once (mkMp replM) myExp :: Maybe Exp)
-- performs the substitution once, if possible.
print $ (once' (mkMp replM) myExp :: Exp)
-- Just for kicks, this returns all possible substitutions
-- where one `Var "x"` is replaced by `Var "y"`.
print $ (once (mkMp replM) myExp :: [Exp])
Yes, I think somewhere (mkMp mySpecificFunction) should do it, if you use a MonadPlus monad and make it succeed when it finds what you're looking for.
A flexible but hacky alternative is to use everywhereM with a State monad that can store a Boolean (or store Maybe MyFunc or whatever) and apply the transformation depending on the state being True or Just myFunc -- that way, when you are done (e.g. after applying the transformation once), you just alter the state to be False/Nothing.

Tying the Knot with a State monad

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

Sort by constructor ignoring (part of) value

Suppose I have
data Foo = A String Int | B Int
I want to take an xs :: [Foo] and sort it such that all the As are at the beginning, sorted by their strings, but with the ints in the order they appeared in the list, and then have all the Bs at the end, in the same order they appeared.
In particular, I want to create a new list containg the first A of each string and the first B.
I did this by defining a function taking Foos to (Int, String)s and using sortBy and groupBy.
Is there a cleaner way to do this? Preferably one that generalizes to at least 10 constructors.
Typeable, maybe? Something else that's nicer?
EDIT: This is used for processing a list of Foos that is used elsewhere. There is already an Ord instance which is the normal ordering.
You can use
sortBy (comparing foo)
where foo is a function that extracts the interesting parts into something comparable (e.g. Ints).
In the example, since you want the As sorted by their Strings, a mapping to Int with the desired properties would be too complicated, so we use a compound target type.
foo (A s _) = (0,s)
foo (B _) = (1,"")
would be a possible helper. This is more or less equivalent to Tikhon Jelvis' suggestion, but it leaves space for the natural Ord instance.
To make it easier to build comparison function for ADTs with large number of constructors, you can map values to their constructor index with SYB:
{-# LANGUAGE DeriveDataTypeable #-}
import Data.Generics
data Foo = A String Int | B Int deriving (Show, Eq, Typeable, Data)
cIndex :: Data a => a -> Int
cIndex = constrIndex . toConstr
Example:
*Main Data.Generics> cIndex $ A "foo" 42
1
*Main Data.Generics> cIndex $ B 0
2
Edit:After re-reading your question, I think the best option is to make Foo an instance of Ord. I do not think there is any way to do this automatically that will act the way you want (just using deriving will create different behavior).
Once Foo is an instance of Ord, you can just use sort from Data.List.
In your exact example, you can do something like this:
data Foo = A String Int | B Int deriving (Eq)
instance Ord Foo where
(A _ _) <= (B _) = True
(A s _) <= (A s' _) = s <= s'
(B _) <= (B _) = True
When something is an instance of Ord, it means the data type has some ordering. Once we know how to order something, we can use a bunch of existing functions (like sort) on it and it will behave how you want. Anything in Ord has to be part of Eq, which is what the deriving (Eq) bit does automatically.
You can also derive Ord. However, the behavior will not be exactly what you want--it will order by all of the fields if it has to (e.g. it will put As with the same string in order by their integers).
Further edit: I was thinking about it some more and realized my solution is probably semantically wrong.
An Ord instance is a statement about your whole data type. For example, I'm saying that Bs are always equal with each other when the derived Eq instance says otherwise.
If the data your representing always behaves like this (that is, Bs are all equal and As with the same string are all equal) then an Ord instance makes sense. Otherwise, you should not actually do this.
However, you can do something almost exactly like this: write your own special compare function (Foo -> Foo -> Ordering) that encapsulates exactly what you want to do then use sortBy. This properly codifies that your particular sorting is special rather than the natural ordering of the data type.
You could use some template haskell to fill in the missing transitive cases. The mkTransitiveLt creates the transitive closure of the given cases (if you order them least to greatest). This gives you a working less-than, which can be turned into a function that returns an Ordering.
{-# LANGUAGE TemplateHaskell #-}
import MkTransitiveLt
import Data.List (sortBy)
data Foo = A String Int | B Int | C | D | E deriving(Show)
cmp a b = $(mkTransitiveLt [|
case (a, b) of
(A _ _, B _) -> True
(B _, C) -> True
(C, D) -> True
(D, E) -> True
(A s _, A s' _) -> s < s'
otherwise -> False|])
lt2Ord f a b =
case (f a b, f b a) of
(True, _) -> LT
(_, True) -> GT
otherwise -> EQ
main = print $ sortBy (lt2Ord cmp) [A "Z" 1, A "A" 1, B 1, A "A" 0, C]
Generates:
[A "A" 1,A "A" 0,A "Z" 1,B 1,C]
mkTransitiveLt must be defined in a separate module:
module MkTransitiveLt (mkTransitiveLt)
where
import Language.Haskell.TH
mkTransitiveLt :: ExpQ -> ExpQ
mkTransitiveLt eq = do
CaseE e ms <- eq
return . CaseE e . reverse . foldl go [] $ ms
where
go ms m#(Match (TupP [a, b]) body decls) = (m:ms) ++
[Match (TupP [x, b]) body decls | Match (TupP [x, y]) _ _ <- ms, y == a]
go ms m = m:ms

Resources