Consider the data type
data Foo f = Foo {fooInt :: f Int, fooBool :: f Bool}
I would like a function mapFoo :: (forall a. f a -> g a) -> Foo f -> Foo g. My options:
I could write it manually. This is mildly annoying, but the killer objection is that I expect Foo to gain fields over time and I want that to be as frictionless as possible, so having to add a case to this function is annoying.
I could write Template Haskell. I'm pretty sure this isn't too hard, but I tend to view TH as a last resort, so I'm hoping for something better.
Could I use generics? I derived Generic, but when I tried to implement the K1 case (specifically to handle Rec0) I couldn't figure out how to do it; I needed it to change the type.
Is there a fourth option that I just missed?
If there is a generic way to write mapFoo without reaching for Template Haskell, I'd love to know about it! Thanks.
The rank2classes package can derive this for you.
{-# LANGUAGE TemplateHaskell #-}
import Rank2.TH (deriveFunctor)
data Foo f = Foo {fooInt :: f Int, fooBool :: f Bool}
$(deriveFunctor ''Foo)
Now you can write mapFoo = Rank2.(<$>).
EDIT: Oh, I should be explicit that this is a manual method - it's a pointer to a package that has lots of useful functions and type classes but afaik no TH to generate what you want. Pull requests welcome, I'm sure.
The parameterized-utils package provides a rich set of higher rank classes. For your needs there's FunctorF:
-- | A parameterized type that is a function on all instances.
class FunctorF m where
fmapF :: (forall x . f x -> g x) -> m f -> m g
And the instances are what you probably expect:
{-# LANGUAGE RankNTypes #-}
import Data.Parameterized.TraversableF
data Foo f = Foo {fooInt :: f Int, fooBool :: f Bool}
instance FunctorF Foo where
fmapF op (Foo a b) = Foo (op a) (op b)
Here is GHC.Generics-based implementation if you still prefer not to use TemplateHaskell:
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.Generics
data Foo f = Foo {
fooInt :: f Int,
fooBool :: f Bool,
fooString :: f String
} deriving (Generic)
class Functor2 p q f where
fmap2 :: (forall a. p a -> q a) -> f p -> f q
instance (Generic (f p), Generic (f q), GFunctor2 p q (Rep (f p)) (Rep (f q))) => Functor2 p q f where
fmap2 f = to . (gfmap2 f) . from
class GFunctor2 p q f g where
gfmap2 :: (forall a. p a -> q a) -> f x -> g x
instance (GFunctor2 p q a b) => GFunctor2 p q (D1 m1 (C1 m2 a)) (D1 m1 (C1 m2 b)) where
gfmap2 f (M1 (M1 a)) = M1 (M1 (gfmap2 f a))
instance (GFunctor2 p q a c, GFunctor2 p q b d) => GFunctor2 p q (a :*: b) (c :*: d) where
gfmap2 f (a :*: b) = gfmap2 f a :*: gfmap2 f b
instance GFunctor2 p q (S1 m1 (Rec0 (p a))) (S1 m1 (Rec0 (q a))) where
gfmap2 f (M1 (K1 g)) = M1 (K1 (f g))
-- Tests
foo = Foo (Just 1) (Just True) (Just "foo")
test1 = fmap2 (\(Just a) -> [a]) foo
test2 = fmap2 (\[a] -> Left "Oops") test1
I'm not sure though if it is possible to avoid MultiParamTypeClasses to make class Functor2 identical to the one defined rank2classes.
Related
Is there a way to define "pairmap" like the following:
pairmap f (x,y) = (f x, f y)
So that the following works:
pairmap (+2) (1::Int, 2::Float)
pairmap succ (1::Int, 'a')
pairmap Just ('a', True)
etc.
Naturally, in the first case, both the elements must be of class Num, and in the second case, both of class Enum. In the third case however, there's no restriction required.
Answer (but could be improved)
The following code (ideone) solves the problem, but note that my functions have to be wrapped in a datatype that encapsulates both the relation between the input and output types and also any constraints on the input type. This works but there's a bit of boilerplate. It would be nice if I could use a bit less boilerplate to achieve this, so any answer would be appreciated (although this solution is reasonably fine for my purposes).
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
import GHC.Exts (Constraint)
class Function f where
type Constraints f a :: Constraint
type instance Constraints f a = ()
type Result f a
type instance Result f a = a
applyFunc :: (Constraints f a) => f -> a -> Result f a
pairmap ::
(Function f, Constraints f a, Constraints f b) =>
f -> (a, b) -> (Result f a, Result f b)
pairmap f (x,y) = (applyFunc f x, applyFunc f y)
data NumFunc where
NumFunc :: (forall a. Num a => a -> a) -> NumFunc
instance Function NumFunc where
type Constraints NumFunc a = (Num a)
applyFunc (NumFunc f) = f
data EnumFunc where
EnumFunc :: (forall a. Enum a => a -> a) -> EnumFunc
instance Function EnumFunc where
type Constraints EnumFunc a = (Enum a)
applyFunc (EnumFunc f) = f
data MaybeFunc where
MaybeFunc :: (forall a. a -> Maybe a) -> MaybeFunc
instance Function MaybeFunc where
type Result MaybeFunc a = Maybe a
applyFunc (MaybeFunc f) = f
y1 = pairmap (NumFunc (+2)) (1::Int, 2::Float)
y2 = pairmap (EnumFunc succ) (1::Int, 'a')
y3 = pairmap (MaybeFunc Just) ('a', True)
main = do
print y1
print y2
print y3
Answer 2
I think this is better and more flexible (ideone), but again, any improvements to reduce the boilerplate welcome:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
import GHC.Exts (Constraint)
data Func (c :: (* -> * -> Constraint)) where
Func :: (forall a b. c a b => a -> b) -> Func c
class (c a, a ~ b) => BasicConstraint c a b
instance (c a, a ~ b) => BasicConstraint c a b
numFunc = Func #(BasicConstraint Num)
enumFunc = Func #(BasicConstraint Enum)
class (c a, t a ~ b) => NewtypeConstraint c t a b
instance (c a, t a ~ b) => NewtypeConstraint c t a b
class EmptyConstraint a
instance EmptyConstraint a
maybeFunc = Func #(NewtypeConstraint EmptyConstraint Maybe)
applyFunc :: Func c -> (forall a b. c a b => a -> b)
applyFunc (Func f) = f
pairmap :: (c a a', c b b') => Func c -> (a, b) -> (a', b')
pairmap f (x,y) = (applyFunc f x, applyFunc f y)
main = do
print $ pairmap (numFunc (+2)) (1::Int, 2::Float)
print $ pairmap (enumFunc succ) (1::Int, 'a')
print $ pairmap (maybeFunc Just) ('a', True)
The first two of your examples are somewhat simpler to generalize than the third.
{-# LANGUAGE RankNTypes, ConstraintKinds, KindSignatures, AllowAmbiguousTypes, TypeApplications #-}
import GHC.Exts (Constraint)
pairmap :: forall (c :: * -> Constraint) d e. (c d, c e) =>
(forall a. (c a) => a -> a) -> (d,e) -> (d,e)
pairmap f (x,y) = (f x, f y)
The caveat with this solution is that you need to explicitly instantiate the constraint you are using:
ghci> pairmap #Num (+1) (1 :: Int, 1.0 :: Float)
(2,2.0)
As for the third, here is a half solutions. If the second type is always a type parametrized over the first (like f a), then you can do the same thing as above (albeit your first examples cease to work - you could make them work by wrapping them in Identity).
pairmap' :: forall (c :: * -> Constraint) f d e. (c d, c e) =>
(forall a. (c a) => a -> f a) -> (d,e) -> (f d,f e)
pairmap' f (x,y) = (f x, f y)
And again, at GHCi
ghci> pairmap' #Num (Just . (+1)) (1 :: Int , 1.0 :: Float)
(Just 2,Just 2.0)
So I've used syb for a long time, and often have functions like
friendlyNames :: Data a => a -> a
friendlyNames = everywhere (mkT (\(Name x _) -> Name x NameS))
What is the equivalent of this using GHC.Generics, assuming Generic a?
This might be the wrong problem to solve with GHC.Generics, but here's now you'd do it!
{-# Language TypeOperators #-}
{-# Language DeriveGeneric #-}
{-# Language DefaultSignatures #-}
{-# Language FlexibleContexts #-}
module Demo where
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
data Record = Record { field0 :: Int, field1 :: Maybe Record, field2 :: Name } deriving Generic
instance FriendlyNames Record -- body omitted and derived with GHC.Generics
instance FriendlyNames a => FriendlyNames (Maybe a)
instance FriendlyNames Int where friendlyNames = id -- no-op
------------------------------------------------------------------------
-- | Class for types that can be made friendly
class FriendlyNames a where
friendlyNames :: a -> a
default friendlyNames :: (GFriendlyNames (Rep a), Generic a) => a -> a
friendlyNames = to . gfriendlyNames . from
-- | Replaces the second component of a name with 'NameS'
instance FriendlyNames Name where
friendlyNames (Name x _) = Name x NameS
------------------------------------------------------------------------
-- | Class for generic structures that can have names made friendly
class GFriendlyNames f where
gfriendlyNames :: f p -> f p
-- | Case for metadata (type constructor, data constructor, field selector)
instance GFriendlyNames f => GFriendlyNames (M1 i c f) where
gfriendlyNames (M1 x) = M1 (gfriendlyNames x)
-- | Case for product types
instance (GFriendlyNames f, GFriendlyNames g) => GFriendlyNames (f :*: g) where
gfriendlyNames (x :*: y) = gfriendlyNames x :*: gfriendlyNames y
-- | Case for sum types
instance (GFriendlyNames f, GFriendlyNames g) => GFriendlyNames (f :+: g) where
gfriendlyNames (L1 x) = L1 (gfriendlyNames x)
gfriendlyNames (R1 y) = R1 (gfriendlyNames y)
-- | Case for datatypes without any data constructors (why not?)
instance GFriendlyNames V1 where
gfriendlyNames v1 = v1 `seq` error "gfriendlyNames.V1"
-- | Case for datatypes without any fields
instance GFriendlyNames U1 where
gfriendlyNames U1 = U1
-- | Case for data constructor fields
instance FriendlyNames a => GFriendlyNames (K1 i a) where
gfriendlyNames (K1 x) = K1 (friendlyNames x)
The GHC.Generics approach is more suited to situations where this kind of complexity can be written once and hidden away in a library. While the SYB approach relies on runtime checks, observe the GHC core that is generated for a friendlyNames that makes Record values friendly
-- RHS size: {terms: 14, types: 18, coercions: 0}
recordFriendlyNames
recordFriendlyNames =
\ w_s63w ->
case w_s63w of _ { Record ww1_s63z ww2_s63A ww3_s63B ->
case $recordFriendlyNames ww1_s63z ww2_s63A ww3_s63B
of _ { (# ww5_s63H, ww6_s63I, ww7_s63J #) ->
Record ww5_s63H ww6_s63I ww7_s63J
}
}
-- RHS size: {terms: 19, types: 19, coercions: 0}
$recordFriendlyNames
$recordFriendlyNames =
\ ww_s63z ww1_s63A ww2_s63B ->
(# ww_s63z,
case ww1_s63A of _ {
Nothing -> Nothing;
Just g1_a601 -> Just (recordFriendlyNames g1_a601)
},
case ww2_s63B of _ { Name x_a3Z3 ds_d5Z5 -> Name x_a3Z3 NameS } #)
Well, I finally have a satisfying answer to this question. The guts of it are taken from glguy's answer above, but I'll add some wrappers and explanation that helped me connect the dots. I will also make it more generic so it corresponds more closely with the tools provide by Data.Data.
The everywhere function will apply a function to every occurence of some Typeable type b within the argument value, which is represented as type a. The Typeable instance is used to determine when a ~ b during the recursion. Note that because everywhere is a method of class Everywhere and a default instance is provided, it will accept any type that satisfies the class constraints
{-# LANGUAGE UndecidableInstances #-}
import Data.Typeable (cast, Typeable)
import GHC.Generics
import Data.Ratio (Ratio)
import Data.Word (Word8)
class (Typeable b, Typeable a) => Everywhere b a where
everywhere :: (b -> b) -> a -> a
Here is the basic instance of Everywhere, it can be applied to any type which satisfies its constraints, in particular GEverywhere which is defined below for any instance of Generic. The OVERLAPPABLE lets us supply instances for additional types that are not instances of Generic.
instance {-# OVERLAPPABLE #-} (Typeable b, Typeable a, Generic a, GEverywhere b (Rep a))
=> Everywhere b a where
everywhere f = to . geverywhere f . from
Now we write a class GEverywhere which includes the instances that cover the type representation. Ultimately, the job of this code is to recurse on the values of the fields inside this value.
class GEverywhere b f where
geverywhere :: (b -> b) -> f p -> f p
instance GEverywhere b f => GEverywhere b (M1 i c f) where
geverywhere f (M1 x) = M1 (geverywhere f x)
instance (GEverywhere b f, GEverywhere b g) => GEverywhere b (f :*: g) where
geverywhere f (x :*: y) = geverywhere f x :*: geverywhere f y
instance (GEverywhere b f, GEverywhere b g) => GEverywhere b (f :+: g) where
geverywhere f (L1 x) = L1 (geverywhere f x)
geverywhere f (R1 y) = R1 (geverywhere f y)
instance GEverywhere b V1 where geverywhere _ v1 =
v1 `seq` error "geverywhere.V1"
instance GEverywhere b U1 where geverywhere _ U1 = U1
This final instance is where the subtype is encountered. We check whether it is the type we are looking for using the cast function from Data.Typeable:
instance Everywhere b a => GEverywhere b (K1 i a) where
geverywhere f (K1 x) =
case cast x :: Maybe b of
Nothing -> K1 (everywhere f x)
Just x' -> case cast (f x') :: Maybe a of
-- This should never happen - we got here because a ~ b
Nothing -> K1 (everywhere f x)
Just x'' -> K1 x''
Finally, there may be primitive types that occur within the types we are interested in that have no Generic instances.
instance (Typeable b, Typeable a) => Everywhere b (Ratio a) where everywhere _ r = r
instance (Typeable b) => Everywhere b Char where everywhere _ r = r
instance (Typeable b) => Everywhere b Integer where everywhere _ r = r
instance (Typeable b) => Everywhere b Word8 where everywhere _ r = r
instance (Typeable b) => Everywhere b Int where everywhere _ r = r
That's it, now we can use everywhere to do generic modification:
λ> everywhere (succ :: Char -> Char) ("abc", 123)
("bcd",123)
λ> everywhere #Int succ ("abc", 123 :: Int)
("abc",124)
{-# LANGUAGE TypeFamilies #-}
import GHC.Prim
import qualified Data.Set as Set
class Functor' f where
type FConstraint f :: * -> Constraint
fmap' :: (FConstraint f a, FConstraint f b) => (a -> b) -> f a -> f b
instance Functor' Set.Set where
type FConstraint Set.Set = Ord Num --error here, won't let me put Num
fmap' = Set.map
I was wondering how I could make the above work. Now I know I could manually require two typeclasses, but I was hoping to be able to combine any arbitrary amount of them.
Now I know requiring Num does not make sense in this case, but this is purely an example.
You will need to define a typeclass (since typeclasses can be partially applied ) which reduces to the constraint you want through a superclass:
{-# LANGUAGE
PolyKinds, UndecidableInstances, TypeOperators
, MultiParamTypeClasses, ConstraintKinds, TypeFamilies
, FlexibleContexts, FlexibleInstances
#-}
class (f x, g x) => (&) f g (x :: k)
instance (f x, g x) => (&) f g x
Clearly (f & g) x holds iff f x and g x hold. The definition of FConstraint' should be obvious now:
class Functor' ...
instance Functor' Set.Set where
type FConstraint Set.Set = Ord & Num
fmap' f = Set.map ( (+1) . f ) -- (+1) to actually use the Num constraint
Looks like the only change I needed to make was not partially apply FConstraint:
{-# LANGUAGE TypeFamilies #-}
import GHC.Prim
import qualified Data.Set as Set
class Functor' f where
type FConstraint f a :: Constraint
fmap' :: (FConstraint f a, FConstraint f b) => (a -> b) -> f a -> f b
instance Functor' Set.Set where
type FConstraint Set.Set a = (Ord a, Num a)
fmap' f = Set.map ((+ 1) . f)
foo = fmap (+ 1) $ Set.fromList [1, 2, 3]
Unfortunately this does not allow me to use a concrete type as far as I can tell, but I suppose that wouldn't even match with Functor on a kind level anyway (Functor has kind * -> * but a list of concrete values such as String has kind *).
It's possible to mix classes with lenses to simulate overloaded record fields, up to a point. See, for example, makeFields in Control.Lens.TH. I'm trying to figure out if there's a nice way to reuse the same name as a lens for some types and a traversal for others. Notably, given a sum of products, each product can have lenses, which will degrade to traversals of the sum. The simplest thing I could think of was this**:
First try
class Boo booey where
type Con booey :: (* -> *) -> Constraint
boo :: forall f . Con booey f => (Int -> f Int) -> booey -> f booey
This works fine for simple things, like
data Boop = Boop Int Char
instance Boo Boop where
type Con Boop = Functor
boo f (Boop i c) = (\i' -> Boop i' c) <$> f i
But it falls on its face as soon as you need anything more complicated, like
instance Boo boopy => Boo (Maybe boopy) where
which should be able to produce a Traversal regardless of the choice of underlying Boo.
Second try
The next thing I tried, which sort of works, is to constrain the Con family. This gets kind of gross. First, change the class:
class LTEApplicative c where
lteApplicative :: Applicative a :- c a
class LTEApplicative (Con booey) => Boo booey where
type Con booey :: (* -> *) -> Constraint
boo :: forall f . Con booey f => (Int -> f Int) -> booey -> f booey
This makes Boo instances carry around explicit evidence that their boo produces a Traversal' booey Int. Some more stuff:
instance LTEApplicative Applicative where
lteApplicative = Sub Dict
instance LTEApplicative Functor where
lteApplicative = Sub Dict
-- flub :: Boo booey => Traversal booey booey Int Int
flub :: forall booey f . (Boo booey, Applicative f) => (Int -> f Int) -> booey -> f booey
flub = case lteApplicative of
Sub (Dict :: Dict (Con booey f)) -> boo
instance Boo boopy => Boo (Maybe boopy) where
type Con (Maybe boopy) = Applicative
boo _ Nothing = pure Nothing
boo f (Just x) = Just <$> hum f x
where hum :: Traversal' boopy Int
hum = flub
And the base Boop example works unchanged.
Why this still sucks
We now have boo producing a Lens or Traversal under appropriate circumstances, and we can always use it as a Traversal, but every time we want to do so, we have to first drag in the evidence that it really is one. This is, of course, far too inconvenient for the purpose of implementing overloaded record fields! Is there any nicer way?
** This code compiles with the following (may not be minimal):
{-# LANGUAGE PolyKinds, TypeFamilies,
TypeOperators, FlexibleContexts,
ScopedTypeVariables, RankNTypes,
KindSignatures #-}
import Control.Lens
import Data.Constraint
The following has worked for me before:
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
import Control.Lens
data Boop = Boop Int Char deriving (Show)
class HasBoo f s where
boo :: LensLike' f s Int
instance Functor f => HasBoo f Boop where
boo f (Boop a b) = flip Boop b <$> f a
instance (Applicative f, HasBoo f s) => HasBoo f (Maybe s) where
boo = traverse . boo
It can be also scaled to polymorphic fields, if we make sure to enforce all the relevant functional dependencies (just like here). Leaving an overloaded field completely polymorphic is rarely useful or a good idea; I illustrate that case though because from there one can always monomorphize as necessary (or we can constrain polymorphic fields, for example a name field to IsString).
{-# LANGUAGE
UndecidableInstances, MultiParamTypeClasses,
FlexibleInstances, FunctionalDependencies, TemplateHaskell #-}
import Control.Lens
data Foo a b = Foo {_fooFieldA :: a, _fooFieldB :: b} deriving Show
makeLenses ''Foo
class HasFieldA f s t a b | s -> a, t -> b, s b -> t, t a -> s where
fieldA :: LensLike f s t a b
instance Functor f => HasFieldA f (Foo a b) (Foo a' b) a a' where
fieldA = fooFieldA
instance (Applicative f, HasFieldA f s t a b) => HasFieldA f (Maybe s) (Maybe t) a b where
fieldA = traverse . fieldA
One can also go a bit wild and use a single class for all "has" functionality:
{-# LANGUAGE
UndecidableInstances, MultiParamTypeClasses,
RankNTypes, TypeFamilies, DataKinds,
FlexibleInstances, FunctionalDependencies,
TemplateHaskell #-}
import Control.Lens hiding (has)
import GHC.TypeLits
import Data.Proxy
class Has (sym :: Symbol) f s t a b | s sym -> a, sym t -> b, s b -> t, t a -> s where
has' :: Proxy sym -> LensLike f s t a b
data Foo a = Foo {_fooFieldA :: a, _fooFieldB :: Int} deriving Show
makeLenses ''Foo
instance Functor f => Has "fieldA" f (Foo a) (Foo a') a a' where
has' _ = fooFieldA
With GHC 8, one can add
{-# LANGUAGE TypeApplications #-}
and avoid the proxies:
has :: forall (sym :: Symbol) f s t a b. Has sym f s t a b => LensLike f s t a b
has = has' (Proxy :: Proxy sym)
instance (Applicative f, Has "fieldA" f s t a b) => Has "fieldA" f (Maybe s) (Maybe t) a b where
has' _ = traverse . has #"fieldA"
Examples:
> Just (Foo 0 1) ^? has #"fieldA"
Just 0
> Foo 0 1 & has #"fieldA" +~ 10
Foo {_fooFieldA = 10, _fooFieldB = 1}
unsafeVacuous in Data.Void.Unsafe and .# and #. in Data.Profunctor.Unsafe both warn about the dangers of using those functions with functors/profunctors that are GADTs. Some dangerous examples are obvious:
data Foo a where
P :: a -> Foo a
Q :: Foo Void
instance Functor Foo where
fmap f (P x) = P (f x)
fmap f Q = P (f undefined)
Here, unsafeVacuous Q will produce a Q constructor with a bogus type.
This example isn't very troubling because it doesn't look even remotely like a sensible Functor instance. Are there examples that do? In particular, would it be possible to construct useful ones that obey the functor/profunctor laws when manipulated only using their public API, but break horribly in the face of these unsafe functions?
I don't believe there's any true functor where unsafeVacuous would cause a problem. But if you write a bad Functor you can make your own unsafeCoerce, which means it should to labeled with {-# LANGUAGE Unsafe #-}. There was an issue about it in void.
Here's an unsafeCoerce I came up with
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
import Data.Void
import Data.Void.Unsafe
type family F a b where
F a Void = a
F a b = b
data Foo a b where
Foo :: F a b -> Foo a b
instance Functor (Foo a) where
fmap = undefined
unsafeCoerce :: forall a b. (F a b ~ b) => a -> b
unsafeCoerce a = (\(Foo b) -> b) $ (unsafeVacuous (Foo a :: Foo a Void) :: Foo a b)
main :: IO ()
main = print $ (unsafeCoerce 'a' :: Int)
which prints 97.