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
Related
I'm trying to use paramorphisms and apomorhisms (in haskell):
-- Fixed point of a Functor
newtype Fix f = In (f (Fix f))
deriving instance (Eq (f (Fix f))) => Eq (Fix f)
deriving instance (Ord (f (Fix f))) => Ord (Fix f)
deriving instance (Show (f (Fix f))) => Show (Fix f)
out :: Fix f -> f (Fix f)
out (In f) = f
type RAlgebra f a = f (Fix f, a) -> a
para :: (Functor f) => RAlgebra f a -> Fix f -> a
para rAlg = rAlg . fmap fanout . out
where fanout t = (t, para rAlg t)
-- Apomorphism
type RCoalgebra f a = a -> f (Either (Fix f) a)
apo :: Functor f => RCoalgebra f a -> a -> Fix f
apo rCoalg = In . fmap fanin . rCoalg
where fanin = either id (apo rCoalg)
to define the following recursive function:
fun concat3 (v,E,r) = add(r,v)
| concat3 (v,l,E) = add(l,v)
| concat3 (v, l as T(v1,n1,l1,r1), r as T(v2,n2,l2,r2)) =
if weight*n1 < n2 then T’(v2,concat3(v,l,l2),r2)
else if weight*n2 < n1 then T’(v1,l1,concat3(v,r1,r))
else N(v,l,r)
It takes two binary trees and an element that is greater than the values in the left tree and less than the values in the right tree and combines them into one binary tree :: value -> tree1 -> tree2 -> tree3
I have defined the add function (which inserts an element into a binary tree) as a paramorphism like so:
add :: Ord a => a -> RAlgebra (ATreeF a) (ATreeF' a)
add elem EmptyATreeF = In (NodeATreeF elem 1 (In EmptyATreeF) (In EmptyATreeF))
add elem (NodeATreeF cur _ (prevLeft, left) (prevRight, right))
| elem < cur = bATreeConstruct cur left prevRight
| elem > cur = bATreeConstruct cur prevLeft right
| otherwise = nATreeConstruct cur prevLeft prevRight
When I try to write concat3 as an apomorphism:
concat3 :: Ord a => a -> RCoalgebra (ATreeF a) (ATreeF' a, ATreeF' a)
concat3 elem (In EmptyATreeF, In (NodeATreeF cur2 size2 left2 right2)) =
out para (insertATreeFSetPAlg elem) (In (NodeATreeF cur2 size2 (Left left2) (Left right2)))
...
Because the next level of the apomorphism has not been evaluated yet, I get a type error from the compiler.
Couldn't match type: Fix (ATreeF a)
with: Either (Fix (ATreeF a)) (ATreeF' a, ATreeF' a)
Expected: ATreeF a (Either (Fix (ATreeF a)) (ATreeF' a, ATreeF' a))
Actual: ATreeF a (Fix (ATreeF a))
Is there another approach I can take?
Some missing context to explain the solution is that this is from an implementation of weight-balanced trees, specifically Adams's variant (which happens to be the data structure behind Data.Set and Data.Map.)
A problem when writing concat3 as a coalgebra is that it is not corecursive, strictly speaking, because the recursive calls of concat3 are under a smart constructor T', i.e., a function (which does some non-trivial rebalancing).
A solution is to introduce an intermediate representation which delays the evaluation of that smart constructor.
-- | Tree with delayed rebalancing operations T', or Id when no rebalancing is needed
data TreeF1 a x = E1 | T' a x x | Id (Tree a)
deriving Functor
So we can write a coalgebra of TreeF1:
concatAlg :: Ord a => a -> RCoalgebra (TreeF1 a) (Tree a, Tree a)
concatAlg v (In E, r) = Id (add r v)
concatAlg v (l, In E) = Id (add l v)
concatAlg v (l#(In (T v1 n1 l1 r1)), r#(In (T v2 n2 l2 r2))) =
if balance * n1 < n2 then T' v2 (Right (l, l2)) (Left (In (Id r2)))
else if balance * n2 < n1 then T' v1 (Left (In (Id l1))) (Right (r1, r))
else Id (_N v1 l r)
{- Reference implementation for comparison:
fun concat3 (v,E,r) = add(r,v)
| concat3 (v,l,E) = add(l,v)
| concat3 (v, l as T(v1,n1,l1,r1), r as T(v2,n2,l2,r2)) =
if weight*n1 < n2 then T’(v2,concat3(v,l,l2),r2)
else if weight*n2 < n1 then T’(v1,l1,concat3(v,r1,r))
else N(v,l,r)
-}
And we can convert a Fix (TreeF1 a) to Fix (Tree a) via a catamorphism, finally executing those delayed applications of rebalancing T'.
_T :: a -> Tree a -> Tree a -> Tree a
_T = error "todo: rebalance"
type Algebra f a = f a -> a
-- do the rebalancing on T' v l r nodes
rebalanceAlg :: Algebra (TreeF1 a) (Tree a)
rebalanceAlg E1 = In E
rebalanceAlg (T' v l r) = _T v l r
rebalanceAlg (Id t) = t
So concat3 is a composition of cata and apo using the above algebras:
concat3 :: Ord a => a -> Tree a -> Tree a -> Tree a
concat3 v l r = (cata rebalanceAlg . apo (concatAlg v)) (l, r)
You can fuse cata and apo so that, after some elementary compiler optimizations, the intermediate tree does not get allocated:
-- fusion of (cata _ . apo _)
cataApo :: Functor f => Algebra f b -> RCoalgebra f a -> a -> b
cataApo alg coalg = go
where
go x = alg (either (cata alg) go <$> coalg x)
concat3' :: Ord a => a -> Tree a -> Tree a -> Tree a
concat3' v l r = cataApo rebalanceAlg (concatAlg v) (l, r)
Full gist: https://gist.github.com/Lysxia/281010fbe40eac9be0b135d4733c3d5a
I was thinking about unzipping operations and realized that one way to express them is by traversing in a Biapplicative functor.
import Data.Biapplicative
class Traversable2 t where
traverse2 :: Biapplicative p
=> (a -> p b c) -> t a -> p (t b) (t c)
-- Note: sequence2 :: [(a,b)] -> ([a], [b])
sequence2 :: (Traversable2 t, Biapplicative p)
=> t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
instance Traversable2 [] where
traverse2 _ [] = bipure [] []
traverse2 f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs
It smells to me as though every instance of Traversable can be transformed mechanically into an instance of Traversable2. But I haven't yet found a way to actually implement traverse2 using traverse, short of converting to and from lists or perhaps playing extremely dirty tricks with unsafeCoerce. Is there a nice way to do this?
Further evidence that anything Traversable is Traversable2:
class (Functor t, Foldable t) => Traversable2 t where
traverse2 :: Biapplicative p
=> (a -> p b c) -> t a -> p (t b) (t c)
default traverse2 ::
(Biapplicative p, Generic1 t, GTraversable2 (Rep1 t))
=> (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f xs = bimap to1 to1 $ gtraverse2 f (from1 xs)
class GTraversable2 r where
gtraverse2 :: Biapplicative p
=> (a -> p b c) -> r a -> p (r b) (r c)
instance GTraversable2 V1 where
gtraverse2 _ x = bipure (case x of) (case x of)
instance GTraversable2 U1 where
gtraverse2 _ _ = bipure U1 U1
instance GTraversable2 t => GTraversable2 (M1 i c t) where
gtraverse2 f (M1 t) = bimap M1 M1 $ gtraverse2 f t
instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :*: u) where
gtraverse2 f (t :*: u) = bimap (:*:) (:*:) (gtraverse2 f t) <<*>> gtraverse2 f u
instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :+: u) where
gtraverse2 f (L1 t) = bimap L1 L1 (gtraverse2 f t)
gtraverse2 f (R1 t) = bimap R1 R1 (gtraverse2 f t)
instance GTraversable2 (K1 i c) where
gtraverse2 f (K1 x) = bipure (K1 x) (K1 x)
instance (Traversable2 f, GTraversable2 g) => GTraversable2 (f :.: g) where
gtraverse2 f (Comp1 x) = bimap Comp1 Comp1 $ traverse2 (gtraverse2 f) x
instance Traversable2 t => GTraversable2 (Rec1 t) where
gtraverse2 f (Rec1 xs) = bimap Rec1 Rec1 $ traverse2 f xs
instance GTraversable2 Par1 where
gtraverse2 f (Par1 p) = bimap Par1 Par1 (f p)
I think I might have something that fits your bill. (Edit: It doesn't, see comments.) You can define newtypes over p () c and p b () and make them Functor instances.
Implementation
Here's your class again with default definitions. I went the route of implementing sequence2 in terms of sequenceA because it seemed simpler.
class Functor t => Traversable2 t where
{-# MINIMAL traverse2 | sequence2 #-}
traverse2 :: Biapplicative p => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f = sequence2 . fmap f
sequence2 :: Biapplicative p => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
Now, the "right part" of the Biapplicative is
newtype R p c = R { runR :: p () c }
instance Bifunctor p => Functor (R p) where
fmap f (R x) = R $ bimap id f x
instance Biapplicative p => Applicative (R p) where
pure x = R (bipure () x)
R f <*> R x =
let f' = biliftA2 const (flip const) (bipure id ()) f
in R $ f' <<*>> x
mkR :: Biapplicative p => p b c -> R p c
mkR = R . biliftA2 const (flip const) (bipure () ())
sequenceR :: (Traversable t, Biapplicative p) => t (p b c) -> p () (t c)
sequenceR = runR . sequenceA . fmap mkR
with the "left part" much the same. The full code is in this gist.
Now we can make p (t b) () and p () (t c) and reassemble them into p (t b) (t c).
instance (Functor t, Traversable t) => Traversable2 t where
sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)
I needed to turn on FlexibleInstances and UndecidableInstances for that instance declaration. Also, somehow ghc wanted a Functor constaint.
Testing
I verified with your instance for [] that it gives the same results:
main :: IO ()
main = do
let xs = [(x, ord x - 97) | x <- ['a'..'g']]
print xs
print (sequence2 xs)
print (sequence2' xs)
traverse2' :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]
traverse2' _ [] = bipure [] []
traverse2' f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs
sequence2' :: Biapplicative p => [p b c] -> p [b] [c]
sequence2' = traverse2' id
outputs
[('a',0),('b',1),('c',2),('d',3),('e',4),('f',5),('g',6)]
("abcdefg",[0,1,2,3,4,5,6])
("abcdefg",[0,1,2,3,4,5,6])
This was a fun exercise!
The following seems to do the trick, exploiting “only” undefined. Possibly the traversable laws guarantee that this is ok, but I've not attempted to prove it.
{-# LANGUAGE GADTs, KindSignatures, TupleSections #-}
import Data.Biapplicative
import Data.Traversable
data Bimock :: (* -> * -> *) -> * -> * where
Bimock :: p a b -> Bimock p (a,b)
Bimfmap :: ((a,b) -> c) -> p a b -> Bimock p c
Bimpure :: a -> Bimock p a
Bimapp :: Bimock p ((a,b) -> c) -> p a b -> Bimock p c
instance Functor (Bimock p) where
fmap f (Bimock p) = Bimfmap f p
fmap f (Bimfmap g p) = Bimfmap (f . g) p
fmap f (Bimpure x) = Bimpure (f x)
fmap f (Bimapp gs xs) = Bimapp (fmap (f .) gs) xs
instance Biapplicative p => Applicative (Bimock p) where
pure = Bimpure
Bimpure f<*>xs = fmap f xs
fs<*>Bimpure x = fmap ($x) fs
fs<*>Bimock p = Bimapp fs p
Bimfmap g h<*>Bimfmap i xs = Bimfmap (\(~(a₁,a₂),~(b₁,b₂)) -> g (a₁,b₁) $ i (a₂, b₂))
$ bimap (,) (,) h<<*>>xs
Bimapp g h<*>xs = fmap uncurry g <*> ((,)<$>Bimock h<*>xs)
runBimock :: Biapplicative p => Bimock p (a,b) -> p a b
runBimock (Bimock p) = p
runBimock (Bimfmap f p) = bimap (fst . f . (,undefined)) (snd . f . (undefined,)) p
runBimock (Bimpure (a,b)) = bipure a b
runBimock (Bimapp (Bimpure f) xs) = runBimock . fmap f $ Bimock xs
runBimock (Bimapp (Bimfmap h g) xs)
= runBimock . fmap (\(~(a₂,a₁),~(b₂,b₁)) -> h (a₂,b₂) (a₁,b₁))
. Bimock $ bimap (,) (,) g<<*>>xs
runBimock (Bimapp (Bimapp h g) xs)
= runBimock . (fmap (\θ (~(a₂,a₁),~(b₂,b₁)) -> θ (a₂,b₂) (a₁,b₁)) h<*>)
. Bimock $ bimap (,) (,) g<<*>>xs
traverse2 :: (Biapplicative p, Traversable t) => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f s = runBimock . fmap (\bcs->(fmap fst bcs, fmap snd bcs)) $ traverse (Bimock . f) s
sequence2 :: (Traversable t, Biapplicative p)
=> t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
And even if this is safe, I wouldn't be surprised if it gives horrible performance, what with the irrefutable patterns and quadratic (or even exponential?) tuple-tree buildup.
A few observations short of a complete, original answer.
If you have a Biapplicative bifunctor, what you can do with it is apply it to something and separate it into a pair of bifunctors isomorphic to its two components.
data Helper w a b = Helper {
left :: w a (),
right :: w () b
}
runHelper :: forall p a b. Biapplicative p => Helper p a b -> p a b
runHelper x = biliftA2 const (flip const) (left x) (right x)
makeHelper :: (Biapplicative p)
=> p a b -> Helper p a b
makeHelper w = Helper (bimap id (const ()) w)
(bimap (const ()) id w)
type Separated w a b = (w a (), w () b)
It would be possible to combine the approaches of #nnnmmm and #leftroundabout by applying fmap (makeHelper . f) to the structure s, eliminating the need for undefined, but then you would need to make Helper or its replacement an instance of some typeclass with the useful operations that let you solve the problem.
If you have a Traversable structure, what you can do is sequenceA Applicative functors (in which case your solution will look like traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f), where your Applicative instance builds a pair of t structures) or traverse it using a Functor (in which case your solution will look like traverse2 f = fromHelper . traverse (g . makeHelper . f) where ...). Either way, you need to define a Functor instance, since Applicative inherits from Functor. You might try to build your Functor from <<*>> and bipure id id, or bimap, or you might work on both separated variables in the same pass.
Unfortunately, to make the types work for the Functor instance, you have to paramaterize :: p b c to a type we would informally call :: w (b,c) where the one parameter is the Cartesian product of the two parameters of p. Haskell’s type system doesn’t seem to allow this without non-standard extensions, but #leftroundabout pulls this off ably with the Bimock class. using undefined to coerce both separated functors to have the same type.
For performance, what you want to do is make no more than one traversal, which produces an object isomorphic to p (t b) (t c) that you can then convert (similar to the Naturality law). You therefore want to implement traverse2 rather than sequence2 and define sequence2 as traverse2 id, to avoid traversing twice. If you separate variables and produce something isomorphic to (p (t b) (), p () (t c)), you can then recombine them as #mmmnnn does.
In practical use, I suspect you would want to impose some additional structure on the problem. Your question kept the components b and c of the Bifunctor completely free, but in practice they will usually be either covariant or contravariant functors that can be sequenced with biliftA2 or traversed together over a Bitraversable rather than Traversable t, or perhaps even have a Semigroup, Applicative or Monad instance.
A particularly efficient optimization would be if your p is isomorphic to a Monoid whose <> operation produces a data structure isomorphic to your t. (This works for lists and binary trees; Data.ByteString.Builder is an algebraic type that has this property.) In this case, the associativity of the operation lets you transform the structure into either a strict left fold or a lazy right fold.
This was an excellent question, and although I don’t have better code than #leftroundabout for the general case, I learned a lot from working on it.
One only mildly evil way to do this is using something like Magma from lens. This seems considerably simpler than leftaroundabout's solution, although it's not beautiful either.
data Mag a b t where
Pure :: t -> Mag a b t
Map :: (x -> t) -> Mag a b x -> Mag a b t
Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
One :: a -> Mag a b b
instance Functor (Mag a b) where
fmap = Map
instance Applicative (Mag a b) where
pure = Pure
(<*>) = Ap
traverse2 :: forall t a b c f. (Traversable t, Biapplicative f)
=> (a -> f b c) -> t a -> f (t b) (t c)
traverse2 f0 xs0 = go m m
where
m :: Mag a x (t x)
m = traverse One xs0
go :: forall x y. Mag a b x -> Mag a c y -> f x y
go (Pure t) (Pure u) = bipure t u
go (Map f x) (Map g y) = bimap f g (go x y)
go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys
go (One x) (One y) = f0 x
go _ _ = error "Impossible"
I have this AST
data ExprF r = Const Int | Add r r
type Expr = Fix ExprF
and I want to compare
x = Fix $ Add (Fix (Const 1)) (Fix (Const 1))
y = Fix $ Add (Fix (Const 1)) (Fix (Const 2))
But all recursion schemes functions seems to work only with single structure
Obviously I can use recursion
eq (Fix (Const x)) (Fix (Const y)) = x == y
eq (Fix (Add x1 y1)) (Fix (Add x2 y2)) = (eq x1 x2) && (eq y1 y2)
eq _ _ = False
But I hope it is possible to use some sort of zipfold function.
Recursion schemes that act on a single argument are enough, because we can return a function from a scheme application. In this case, we can return an Expr -> Bool function from a scheme application on Expr. For efficient equality checking we only need paramorphisms:
{-# language DeriveFunctor, LambdaCase #-}
newtype Fix f = Fix (f (Fix f))
data ExprF r = Const Int | Add r r deriving (Functor, Show)
type Expr = Fix ExprF
cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = go where go (Fix ff) = f (go <$> ff)
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f (Fix ff) = f ((\x -> (x, para f x)) <$> ff)
eqExpr :: Expr -> Expr -> Bool
eqExpr = cata $ \case
Const i -> cata $ \case
Const i' -> i == i'
_ -> False
Add a b -> para $ \case
Add a' b' -> a (fst a') && b (fst b')
_ -> False
Of course, cata is trivially implementable in terms of para:
cata' :: Functor f => (f a -> a) -> Fix f -> a
cata' f = para (\ffa -> f (snd <$> ffa)
Technically, almost all useful functions are implementable using cata, but they aren't necessarily efficient. We can implement para using cata:
para' :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para' f = snd . cata (\ffa -> (Fix (fst <$> ffa) , f ffa))
However, if we use para' in eqExpr we get quadratic complexity, since para' is always linear in the size of the input, while we can use para to peek at the topmost Expr values in constant time.
(This response uses the data-fix library because I couldn't get recursion-schemes to compile.)
We can model the diff of two trees as an anamorphism or unfolding of a "diff functor" that is based on the original functor.
Consider the following types
data DiffF func r = Diff (Fix func) (Fix func)
| Nodiff (func r)
deriving (Functor)
type ExprDiff = Fix (DiffF ExprF)
The idea is that ExprDiff will follow the "common structure" of the original Expr trees as long as it remains equal, but at the moment a difference is encountered, we switch to the Diff leaf, that stores the two subtrees that we found to be different.
The actual comparison function would be:
diffExpr :: Expr -> Expr -> ExprDiff
diffExpr e1 e2 = ana comparison (e1,e2)
where
comparison :: (Expr,Expr) -> DiffF ExprF (Expr,Expr)
comparison (Fix (Const i),Fix (Const i')) | i == i' =
Nodiff (Const i')
comparison (Fix (Add a1 a2),Fix (Add a1' a2')) =
Nodiff (Add (a1,a1') (a2,a2'))
comparison (something, otherthing) =
Diff something otherthing
The "seed" of the anamorphism is the pair of expressions we want to compare.
If we simply want a predicate Expr -> Expr -> Bool we can later use a catamorphism that detects the presence of Diff branches.
I am looking for practical strategies or tips for dealing with constraints in haskell, as illustrated by the case below.
I have a functor Choice and I want to transform an interpreter from Choice x functor to m x to an interpreter from Free Choice x to m x.
-- Choice : endofunctor
data Choice next = Choice next next deriving (Show)
instance Functor Choice where
fmap f (Choice a b) = Choice (f a) (f b)
-- I have a function from the functor to a monad m
inter1 :: Choice x -> IO x
inter1 (Choice a b) = do
x <- readLn :: IO Bool
return $ if x then a else b
-- universal property gives me a function from the free monad to m
go1 :: Free Choice x -> IO x
go1 = interpMonad inter1
where
type Free f a = FreeT f Identity a
data FreeF f r x = FreeF (f x) | Pure r deriving (Show)
newtype FreeT f m r = MkFreeT { runFreeT :: m (FreeF f r (FreeT f m r)) }
instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where
showsPrec d (MkFreeT m) = showParen (d > 10) $
showString "FreeT " . showsPrec 11 m
instance (Functor f, Monad m) => Functor (FreeT f m) where
fmap (f::a -> b) (x::FreeT f m a) =
MkFreeT $ liftM f' (runFreeT x)
where f' :: FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b)
f' (FreeF (fx::f (FreeT f m a))) = FreeF $ fmap (fmap f) fx
f' (Pure r) = Pure $ f r
instance (Functor f, Monad m) => Applicative (FreeT f m) where
pure a = MkFreeT . return $ Pure a
(<*>) = ap
instance (Functor f, Monad m) => Monad (FreeT f m) where
return = MkFreeT . return . Pure
(MkFreeT m) >>= (f :: a -> FreeT f m b) = MkFreeT $ -- m (FreeF f b (FreeT f m b))
m >>= -- run the effect in the underlying monad !
\case FreeF fx -> return . FreeF . fmap (>>= f) $ fx -- continue to run effects
Pure r -> runFreeT (f r) -- apply the transformation
interpMonad :: (Functor f, Functor m, Monad m) =>
(forall x . f x -> m x) ->
forall x. Free f x -> m x
interpMonad interp (MkFreeT iFfxF) = (\case
Pure x -> return x
FreeF fxF -> let mmx = interp $ fmap (interpMonad interp) fxF
in join mmx) . runIdentity $ iFfxF
All is fine until I require Show x in my interpreter.
interp2 :: Show x => Choice x -> IO x
interp2 (Choice a b) = return a -- we follow left
go2 :: Show x => Free Choice x -> IO x
go2 = interpMonad interp2 -- FAILS
Then it can not find the show constraint to apply in interp2
I suspected the quantifiers were the problem, so I simplified to
lifting :: (forall x . x -> b) ->
(forall x. x -> b)
lifting = id
lifting2 :: (forall x . Show x => x -> b) ->
(forall x . Show x => x -> b)
lifting2 = id
somefunction :: Show x => x -> String
somefunction = lifting show -- FAILS
somefunction2 :: Show x => x -> String
somefunction2 = lifting2 show -- OK
This highlight the problem : Could not deduce (Show x1) arising from a use of ‘show’ from the context (Show x) we have two distinct type variable, and constraint do not flow from one to the other.
I could write some specialized function playing with the constraints as follows (does not work btw) but my question is what are the practical strategies for dealing with this ? (the equivalent of undefined, look at the type, go on...)
interpMonad2 :: (Functor f, Functor m, Monad m) =>
(forall x . ( Show (f x)) => f x -> m x) ->
forall x. ( Show (Free f x)) => Free f x -> m x
interpMonad2 interp (MkFreeT iFfxF) = (\case
Pure x -> return x
FreeF fxF -> let mmx = interp $ fmap (interpMonad interp) fxF
in join mmx) . runIdentity $ iFfxF
edit
based on the answer provided, here is the modification for the lifting function.
lifting :: forall b c. Proxy c
-> (forall x . c x => x -> b)
-> (forall x . c x => x -> b)
lifting _ = id
somefunction3 :: Show x => x -> String
somefunction3 = lifting (Proxy :: Proxy Show) show
I don't see your interpMonad function, so I will include one possible definition here:
interpMonad :: forall f m x . (Functor f, Monad m)
=> (forall y . f y -> m y) -> Free f x -> m x
interpMonad xx = go . runIdentity . runFreeT where
go (FreeF x) = xx x >>= go . runIdentity . runFreeT
go (Pure x) = return x
In order to also have a class constraint on the inner function, you simply add the constraint to the inner function. You also need the correct constraint on the type Free, and you need the extra Proxy to help the typechecker out a bit. Otherwise, the definition of the function is identical:
interpMonadC :: forall f m x c . (Functor f, Monad m, c (Free f x))
=> Proxy c
-> (forall y . c y => f y -> m y)
-> (Free f x -> m x)
interpMonadC _ xx = go . runIdentity . runFreeT where
go (FreeF x) = xx x >>= go . runIdentity . runFreeT
go (Pure x) = return x
And now quite simply:
>:t interpMonadC (Proxy :: Proxy Show) interp2
interpMonadC (Proxy :: Proxy Show) interp2
:: Show x => Free Choice x -> IO x
András Kovács proposed this question in response to an answer to a previous question.
In a lens-style uniplate library for types of kind * -> * based on the class
class Uniplate1 f where
uniplate1 :: Applicative m => f a -> (forall b. f b -> m (f b)) -> m (f a)
analogous to the class for types of kind *
class Uniplate on where
uniplate :: Applicative m => on -> (on -> m on) -> m on
is it possible to implement analogs to contexts and holes, which both have the type Uniplate on => on -> [(on, on -> on)] without requiring Typeable1?
It's clear that this could be implemented in the old-style of the uniplate library which used Str to represent the structure of the data by returning a structure with a type-level list of the types of the children.
A hole could be represented by the following data type, which would replace (on, on -> on) in the signatures for contexts and holes
data Hole f a where
Hole :: f b -> (f b -> f a) -> Hole f a
holes :: Uniplate1 f => f a -> [Hole f a]
...
However, it is unclear if there is an implementation for holes which doesn't require Typeable1.
The suggested type Hole is needlessly restrictive in the return type of the function. The following type can represent everything the former Hole represents, and more, without loss of any type information.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
data Hole f a where
Hole :: f b -> (f b -> a) -> Hole f a
If we need to have a return type of f a, we can use Hole f (f a) to represent it. Since we will be using Holes a lot, it'd be nice to have a few utility functions. Because the return type of the function in Hole is no longer constrained to be in f, we can make a Functor instance for it
instance Functor (Hole f) where
fmap f (Hole b g) = Hole b (f . g)
contexts1 can be written for either version of Hole by replacing the constructors for tuples in the uniplate library's contexts with Hole:
contexts1 :: Uniplate1 f => f a -> [Hole f (f a)]
contexts1 x = Hole x id : f (holes1 x)
where
f xs = [ Hole y (ctx . context)
| Hole child ctx <- xs
, Hole y context <- contexts1 child]
holes1 is trickier, but can still be made by modifying holes from the uniplate library. It requires a new Replace1 Applicative Functor that uses Hole instead of a tuple. Everyhwere the second field of the tuple was modified by second (f .) we replace with fmap f for the Hole.
data Replace1 f a = Replace1 {replaced1 :: [Hole f a], replacedValue1 :: a}
instance Functor (Replace1 f) where
fmap f (Replace1 xs v) = Replace1 (map (fmap f) xs) (f v)
instance Applicative (Replace1 f) where
pure v = Replace1 [] v
Replace1 xs1 f <*> Replace1 xs2 v = Replace1 (ys1 ++ ys2) (f v)
where ys1 = map (fmap ($ v)) xs1
ys2 = map (fmap (f)) xs2
holes1 :: Uniplate1 f => f a -> [Hole f (f a)]
holes1 x = replaced1 $ descendM1 (\v -> Replace1 [Hole v id] v) x
decendM1 is defined in the preceding answer. Replace and Replace1 can be unified; how to do so is described after the examples.
Let's try some examples in terms of the code in the previous question. The following utility functions on Holes will be useful.
onHole :: (forall b. f b -> c) -> Hole f a -> c
onHole f (Hole x _) = f x
inHole :: (forall b. f b -> f b) -> Hole f a -> a
inHole g (Hole x f) = f . g $ x
Examples
We'll use the following example data and function, based on the code from the preceding questions:
example = If (B True) (I 2 `Mul` I 3) (I 1)
zero :: Expression b -> Expression b
zero x = case x of
I _ -> I 0
B _ -> B False
Add _ _ -> I 0
Mul _ _ -> I 0
Eq _ _ -> B False
And _ _ -> B False
Or _ _ -> B False
If _ a _ -> zero a
Holes
sequence_ . map (onHole print) . holes1 $ example
B True
Mul (I 2) (I 3)
I 1
Contexts
sequence_ . map (onHole print) . contexts1 $ example
If (B True) (Mul (I 2) (I 3)) (I 1)
B True
Mul (I 2) (I 3)
I 2
I 3
I 1
Replacement of each context
sequence_ . map print . map (inHole zero) . contexts1 $ example
I 0
If (B False) (Mul (I 2) (I 3)) (I 1)
If (B True) (I 0) (I 1)
If (B True) (Mul (I 0) (I 3)) (I 1)
If (B True) (Mul (I 2) (I 0)) (I 1)
If (B True) (Mul (I 2) (I 3)) (I 0)
Unifying Replace
The Replace Applicative Functor can be refactored so that it doesn't know about the type of holes for either Uniplate or Uniplate1, and instead only knows that the hole is a Functor. Holes for Uniplate were using the type (on, on -> a) and essentially using fmap f = second (f .); this is the composition of the (on, ) and on-> functors.
Instead of grabbing Compose from the transformers library, we'll make a new type for a Hole for Uniplate, which will make the example code here be more consistent and self-contained.
data Hole on a = Hole on (on -> a)
instance Functor (Hole on) where
fmap f (Hole on g) = Hole on (f . g)
We'll rename our Hole from before to Hole1.
data Hole1 f a where
Hole1 :: f b -> (f b -> a) -> Hole1 f a
instance Functor (Hole1 f) where
fmap f (Hole1 b g) = Hole1 b (f . g)
Replace can drop all knowledge of either type of hole.
data Replace f a = Replace {replaced :: [f a], replacedValue :: a}
instance Functor f => Functor (Replace f) where
fmap f (Replace xs v) = Replace (map (fmap f) xs) (f v)
instance Functor f => Applicative (Replace f) where
pure v = Replace [] v
Replace xs1 f <*> Replace xs2 v = Replace (ys1 ++ ys2) (f v)
where ys1 = map (fmap ($ v)) xs1
ys2 = map (fmap (f)) xs2
Both holes and holes1 can be implemented in terms of the new Replace.
holes :: Uniplate on => on -> [Hole on on]
holes x = replaced $ descendM (\v -> Replace [Hole v id] v) x
holes1 :: Uniplate1 f => f a -> [Hole1 f (f a)]
holes1 x = replaced $ descendM1 (\v -> Replace [Hole1 v id] v) x