I would like to union two Map instances with a monadic function. This becomes a problem because of the unionWith type signature:
unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
I'm looking for a smart way to do this. Here is my naive implementation:
monadicUnionWith :: (Monad m, Ord k) => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
monadicUnionWith f mapA mapB = do
let overlapping = toList $ intersectionWith (\a b -> (a,b)) mapA mapB
mergedOverlapping <- liftM fromList $ mapM helper overlapping
return $ union (union mergedOverlapping mapA) mapB
where
helper (k, (a,b)) = do
c <- f a b
return (k, c)
Note that union is left biased
Not sure if it is more efficient, but it is somewhat cooler (as it involves storing monadic values in the map):
monadicUnionWith :: (Monad m, Ord k) => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
monadicUnionWith f mapA mapB =
Data.Traversable.sequence $ unionWith (\a b -> do {x <- a; y <- b; f x y}) (map return mapA) (map return mapB)
And if you want you can use
(\a b -> join (liftM2 f a b))
as the parameter to unionWith, or even
((join.).(liftM2 f))
Related
Today I had two maps I needed to combine: consMaps :: Map k a -> Map k b -> Map k (a, b). Seeing nothing in Data.Map, I set out to implement this and came up with something unexpectedly ugly:
consMaps :: Map k a -> Map k b -> Map k (a, b)
consMaps ma mb = mapMapMaybe g (Map.unionWith f a' b')
where
a' :: Map k (Maybe (Maybe a, Maybe b))
a' = fmap (\a -> Just (Just a, Nothing)) ma
b' :: Map k (Maybe (Maybe a, Maybe b))
b' = fmap (\b -> Just (Nothing, Just b)) mb
f :: Maybe (Maybe a, Maybe b) -> Maybe (Maybe a, Maybe b) -> Maybe (Maybe a, Maybe b)
f (Just (Just a, _)) (Just (_, Just b)) = Just (Just a, Just b)
f (Just (_, Just b)) (Just (Just a, _)) = Just (Just a, Just b)
-- f (Just a, Just b) _ = Just (a, b) -- impossible in this context
-- f _ (Just a, Just b) = Just (a, b) -- impossible in this context
f _ _ = Nothing
g :: Maybe (Maybe a, Maybe b) -> Maybe (a, b)
g (Just (Just a, Just b)) = Just (a, b)
g _ = Nothing
mapMapMaybe :: (a -> Maybe b) -> Map k a -> Map k b
mapMapMaybe f mp = snd (mapEither (maybe (Left ()) Right . f) mp)
Am I missing something? Is this as good as this gets?
It looks like your consMaps implementation, with the signature you've given, is just
consMaps :: Map k a -> Map k b -> Map k (a, b)
consMaps = intersectionWith (,)
If instead you wanted a Map k (Maybe a, Maybe b), I might write that as
consMaps :: Map k a -> Map k b -> Map k (Maybe a, Maybe b)
consMaps ma mb = unionWith combine ma' mb' where
ma' = fmap (\ a -> (Just a, Nothing)) ma
mb' = fmap (\ b -> (Nothing, Just b)) mb
combine (a, _) (_, b) = (a, b)
If you want Map (a, b) out then use the other answer (intersectionWith). If you want a Map (Maybe a, Maybe b) then that specialized function won't work. Instead, containers has a merge function, which covers "basically all" ways to combine Maps. It takes three strategies: what to do if a key is only in the left map, what to do if a key is only in the right map, and what to do if a key is in both. The strategies are built using helper functions. The idea is that merge does exactly one traversal of the inputs, so is more efficient than e.g. mapping the inputs and then combining.
import Data.Map.Merge.Lazy
catMaps :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b)
catMaps = merge left right both
where left = mapMissing $ \_ a -> (Just a, Nothing)
right = mapMissing $ \_ b -> (Nothing, Just b)
both = zipWithMatched $ \_ a b -> (Just a, Just b)
Note that the "right" type for the output in this version is actually Map k (These a b), where These models "inclusive or":
data These a b = This a | That b | These a b
theseMaps :: Ord k => Map k a -> Map k b -> Map k (These a b)
theseMaps = merge left right both
where left = mapMissing $ const This
right = mapMissing $ const That
both = zipWithMatched $ const These
How do I write the Traversable instance for ((->) a)?
I think I could do it, if I could generically unwrap an Applicative Functor:
instance Traversable ((->) k) where
-- traverse :: (a -> f b) -> (k -> a) -> f (k -> b)
-- traverse h t = ?
-- h :: Applicative f => a -> f b
-- t :: k -> a
-- h . t :: k -> f b
-- unwrap . h . t :: k -> b
-- pure $ unwrap . h . t :: f (k -> b)
traverse h t = pure $ unwrap . h . t
unwrap :: (Functor f, Applicative f) => f a -> a
unwrap y#(pure x) = x
But, alas, GHC won't let me get away with that:
Parse error in pattern: pure
Generally there is no such thing as unwrap, consider f being the list functor [] what should unwrap return for [_, _, _] or better yet for the empty list []? Similar thing with Maybe, suppose h is const Nothing, you would expect to get Nothing. But your line of thought would fail upon trying to unwrap the Nothing into a value a. You can notice that trying to apply pure (to re-pack the result in the functor) means that you expect the result to be always Just for Maybe functor, non-empty for [] etc.
There is little hope for Traversable instance for a reader functor ((->) k). While it is not proof, a good evidence in that direction is that such an instance is missing from the Prelude. Also to traverse a function and produce a final container ([] or Maybe) you would need to apply your function h to any thinkable output of the function, that is a lot of potential values, in general infinitely many.
Prelude> traverse (\n -> if n == 42 then Nothing else Just n) [1, 2, 3]
Just [1,2,3]
Prelude> traverse (\n -> if n == 42 then Nothing else Just n) [1..]
Nothing
suppose that k is Int, so the functor is Int ->, suppose you have a value g :: Int -> Int, let it be \n -> if n == 42 then 0 else n, suppose you wanted to traverse that value with the above function, that traversal would be Nothing if g outputs 42 for any input, but it doesn't. The traversal cannot know that though (it has no access to the code of the function), so it would have to try all outputs.
If k were finite, then you could traverse a function by tabulating it. After traversing the table you could possibly produce a result. This may not be what you are after but:
import Data.Char
import Data.Maybe
import Data.Word
instance ( Enum k, Bounded k ) => Foldable ((->) k) where
foldMap h f = foldMap (h . f) domain
instance ( Enum k, Bounded k, Eq k ) => Traversable ((->) k) where
traverse h f = fmap (\vs k -> fromJust $ k `lookup` zip domain vs) (traverse (h . f) domain)
domain :: ( Enum k, Bounded k ) => [k]
domain = enumFromTo minBound maxBound
tabulate :: ( Enum k, Bounded k ) => (k -> a) -> [(k, a)]
tabulate f = zip domain (map f domain)
f1 :: Bool -> Int
f1 b = if b then 42 else 666
f2 :: Ordering -> Char
f2 LT = 'l'
f2 EQ = 'e'
f2 GT = 'g'
f3 :: Word8 -> Bool
f3 n = fromIntegral n < 256
f4 :: Word16 -> Bool
f4 n = fromIntegral n < 256
main = do
print (tabulate f1)
print (tabulate <$> traverse (\n -> [n, 2*n]) f1)
putStrLn ""
print (tabulate f2)
print (tabulate <$> traverse (\c -> [c, toUpper c]) f2)
putStrLn ""
print (tabulate f3)
print (tabulate <$> traverse (\b -> if b then Just b else Nothing) f3)
putStrLn ""
print (tabulate <$> traverse (\b -> if b then Just b else Nothing) f4)
But, alas, GHC won't let me get away with that:
It seems your error is that you tried to use a function (pure) as a pattern. Haskell only allows constructors to appear in patterns. So
unwrap (Just x) = x
is valid, while
unwrap (pure x) = x
is not.
Given a simple "language":
data Expr a where
ConstE :: a -> Expr a
FMapE :: (b -> a) -> Expr b -> Expr a
instance Functor Expr where
fmap = FMapE
interpret :: Expr a -> a
interpret (ConstE a) = a
interpret (FMapE f a) = f (interpret a)
From that I would like to extract a call graph, eg:
foo = fmap show . fmap (*2) $ ConstE 1
Should result in the graph Node 1 -> Node (*2) -> Node show. Ideally I'd like to store this in a Data.Graph.
What I've come up to this point is that it should be possible to use System.Mem.StableNames to identify individual nodes and store them in a HashMap (StableName (Expr a)) (Expr a).
toHashMap :: Expr a -> HashMap (StableName (Expr a)) (Expr a)
toHashMap n#ConstE = do
sn <- makeStableName n
return $ HashMap.singleton sn n
The problem is, that there seems to be no way to get through the FMapE nodes:
toHashMap n#(FMapE _ a) = do
snN <- makeStableName n
snA <- makeStableName a
-- recurse
hmA <- toHashMap a
-- combine
return $ HashMap.singleton snN n `HashMap.union` hmA
GHC will complain along the lines of this:
Couldn't match type ‘t’ with ‘b’
because type variable ‘b’ would escape its scope
This (rigid, skolem) type variable is bound by
a pattern with constructor
FMapE :: forall a b. (b -> a) -> Expr b -> Expr a,
in an equation for ‘toHashMap’
I can see that this won't match ... but I have no clue on how to make this work.
Edit
This probably boils down to writing a children function:
children :: Event a -> [Event a]
children (ConstE) = []
children (FMapE _ a) = [a] -- doesn't match ...
For the same reason I can't uniplate on this ...
You can get a postorder traversal, which is a tolopogical sort for a tree, of a type of kind * -> * from the Uniplate1 class I've described previously.
{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Monad.Identity
class Uniplate1 f where
uniplate1 :: Applicative m => f a -> (forall b. f b -> m (f b)) -> m (f a)
descend1 :: (forall b. f b -> f b) -> f a -> f a
descend1 f x = runIdentity $ descendM1 (pure . f) x
descendM1 :: Applicative m => (forall b. f b -> m (f b)) -> f a -> m (f a)
descendM1 f a = uniplate1 a f
transform1 :: Uniplate1 f => (forall b. f b -> f b) -> f a -> f a
transform1 f = f . descend1 (transform1 f)
transform1 is a generic postorder tranformation. A generic postorder Monadic traversal of a Uniplate1 is
transformM1 :: (Uniplate1 f, Applicative m, Monad m) =>
(forall b. f b -> m (f b)) ->
f a -> m (f a)
transformM1 f = (>>= f) . descendM1 (transformM1 f)
We can write a Uniplate1 instance for Expr:
instance Uniplate1 Expr where
uniplate1 e p = case e of
FMapE f a -> FMapE f <$> p a
e -> pure e
We'll make a simple dump function for demonstration purposes and bypass to restore the data after a monadic effect.
dump :: Expr b -> IO ()
dump (ConstE _) = putStrLn "ConstE"
dump (FMapE _ _) = putStrLn "FMapE"
bypass :: Monad m => (a -> m ()) -> a -> m a
bypass f x = f x >> return x
We can traverse your example in topological order
> transformM1 (bypass dump) (fmap show . fmap (*2) $ ConstE 1)
ConstE
FMapE
FMapE
Suppose I have definitions as follows (where cata is the catamorphism):
type Algebra f a = f a -> a
newtype Fix f = Fx (f (Fix f))
unFix :: Fix f -> f (Fix f)
unFix (Fx x) = x
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unFix
I was wondering if there would be some way to modify the definition of cata so that I could chain some object such as an int through it such that I could generate unique handles for things within the alg function, i.e. "a0", "a1", "a2", ..., etc.
Edit: To make this more clear, I'd like to be able to have some function cata' such that when I have something similar to the following definitions
data IntF a
= Const Int
| Add a a
instance Functor IntF where
fmap eval (Const i) = Const i
fmap eval (x `Add` y) = eval x `Add` eval y
alg :: Int -> Algebra IntF String
alg n (Const i) = "a" ++ show n
alg n (s1 `Add` s2) = s1 ++ " && " ++ s2
eval = cata' alg
addExpr = Fx $ (Fx $ Const 5) `Add` (Fx $ Const 4)
run = eval addExpr
then run evaluates to "a0 && a1" or something similar, i.e. the two constants don't get labeled the same thing.
Just sequence them as monads.
newtype Ctr a = Ctr { runCtr :: Int -> (a, Int) } -- is State Int
instance Functor Ctr
instance Applicative Ctr
instance Monad Ctr
type MAlgebra m f a = f (m a) -> m a
fresh :: Ctr Int
fresh = Ctr (\i -> (i, i+1))
data IntF a
= Val
| Add a a
malg :: IntF (Ctr String) -> Ctr String
malg Val = (\x -> "a" ++ show x) <$> fresh
malg (Add x y) = (\a b -> a ++ " && " ++ b) <$> x <*> y
go = cata malg
As I understand, you want something like
cata' :: Functor f => (Int -> f a -> a) -> Fix f -> a
so that you can operate both on f a and it's index.
If that's true, here's a possible solution.
Associated Int
First we define a new type which will represent Int-labelled functor:
{-# LANGUAGE DeriveFunctor #-}
data IntLabel f a = IntLabel Int (f a) deriving (Functor)
-- This acts pretty much like `zip`.
labelFix :: Functor f => [Int] -> Fix f -> Fix (IntLabel f)
labelFix (x:xs) (Fx f) = Fx . IntLabel x $ fmap (labelFix xs) f
Now we can define cata' using cata and labelFix:
cata' :: Functor f => (Int -> f a -> a) -> Fix f -> a
cata' alg = cata alg' . labelFix [1..]
where
alg' (IntLabel n f) = alg n f
NOTE: unique Ints are assigned to each layer, not each functor. E.g. for Fix [] each sublist of the outermost list will be labelled with 2.
Threading effects
A different approach to the problem would be to use cata to produce monadic value:
cata :: Functor f => (f (m a) -> m a) -> Fix f -> m a
This is just a specialized version of cata. With it we can define (almost) cat' as
cata'' :: Traversable f => (Int -> f a -> a) -> Fix f -> a
cata'' alg = flip evalState [1..] . cata alg'
where
alg' f = alg <$> newLabel <*> sequenceA f
newLabel :: State [a] a
newLabel = state (\(x:xs) -> (x, xs))
Note that Traversable instance now is needed in order to switch f (m a) to m (f a).
However, you might want to use just a bit more specialized cata:
cata :: (Functor f, MonadReader Int m) => (f (m a) -> m a) -> Fix f -> m a
I'm implementing a fairly vanilla binary tree, and I'm implementing an insertWith function, such that you can insert values by transforming existing values into their "keys" - this may allow you to, say, store a tuple of (key, value) and just compare the keys when inserting new "nodes". The implementation is the following:
insertWith :: (Ord b) => (a -> b) -> BinTree a -> a -> BinTree a
insertWith _ EmptyTree y = Node y EmptyTree EmptyTree
insertWith f (Node x l r) y =
case compare (f y) (f x) of
LT -> Node x (insertWith f l y) r
EQ -> Node x l r
GT -> Node x l (insertWith f r y)
When I partially apply this with fst using let in GHCi, I get the following:
let insertWith_ = insertWith fst
:t insertWith_
insertWith_ :: BinTree ((), b) -> ((), b) -> BinTree ((), b)
However, leaving out the let step gives the following:
:t insertWith fst
insertWith fst
:: (Ord a) => BinTree (a, b) -> (a, b) -> BinTree (a, b)
I think it has something to do with the (Ord b) in the type signature, but I'm just wondering why GHCi transforms the type signature like this when using let? Thanks in advance for any answers.