I'm trying to use generic programming as described in the paper Scrap Your Boilerplate with class. That is, being able to "recurse" down with the members of a user-defined class, as opposed to a fixed set of types that are known when the traversal code is written.
It appears the corresponding hackage package http://hackage.haskell.org/package/syb-with-class can be used for this purpose, but most of the online discussion (for instance this question from 7 years ago: Does the current SYB permit extension of generic functions with new types?) implies current GHC.Generics to be preferred. In particular, that implementation seems to predate the use of constraint-kinds which is supposed to make this sort of programming easier. However, the GHC.Generics framework does not seem to permit traversals with extensible functions.
What's the best alternative these days for doing generic functions with extensible types? If at all possible, I'd like to avoid using "internal" representations (i.e., any sort of K1, M1 etc. combinators) and would love to be able to use a Uniplate like interface. Any pointers to papers, blog-posts, or general advice would be appreciated.
Well, here's a blog post for you...
If you want to do generic programming as described in the "Scrap Your Boilerplate with class" paper, then the recommended method is to use the syb-with-class package, notwithstanding that Stack Overflow answer, since the syb-with-class package is actively maintained and works just fine.
If you want to do generic programming with extensible types directly with GHC.Generics, then -- as with any other direct use of GHC.Generic -- you can't really avoid using the K1, M1, etc. representation. It's unfortunate that the documentation makes this representation sound like an internal implementation detail that is subject to change at any minute.
The potential advantage of GHC.Generics is that it's naturally type-class-based, so you get the type extensibility for free. For example, to take the gsize example from the SYB with class paper, you can implement it in GHC.Generics directly with a pair of classes, one for handling the generic structure, and another for handling the specific types along the way:
-- Handle the generic structure
class Size' f where
size' :: f p -> Int
instance (Size' f) => Size' (M1 i c f) where
size' (M1 x) = size' x
instance (Size' f, Size' g) => Size' (f :+: g) where
size' (L1 x) = size' x
size' (R1 x) = size' x
instance (Size' f, Size' g) => Size' (f :*: g) where
size' (f :*: g) = size' f + size' g
instance (Size' U1) where
size' U1 = 0 -- constructor already counted by Size class
instance (Size' V1) where
size' _ = undefined
instance (Size c) => Size' (K1 i c) where
size' (K1 x) = size x
-- Handle the types
class Size t where
size :: t -> Int
default size :: (Generic t, Size' (Rep t)) => t -> Int
size t = 1 + size' (from t)
Generally, there would be no need to extend Size', as it's -- by construction -- a type-agnostic, generic implementation that will have an exhaustive (or nearly exhaustive) set of instances. However, the Size type class is, obviously, open and can be extended at will:
data Name = N String
instance Size Name where
size (N _) = 1
-- a fanciful example of a custom recursive type
newtype Negative a = Neg a
instance Size a => Size (Negative a) where
size (Neg x) = -size x
-- a user-defined type using a default instance
data Something = Something Int (Name, Name) Bool deriving (Generic)
instance Size Something
-- needs some supporting default instances:
instance Size Bool
instance (Size a, Size b) => Size (a,b)
-- and a custom instance. This could be defaulted, but
-- then we'd need an instance for unboxed Int#
instance Size Int where size _ = 1
main = do
print $ size (Something 10 (N "John", N "Doe") False)
print $ size (Neg (1 :: Int, 2 :: Int), True)
Because the generic Size' class is indeed generic, it's possible to generalize it to an "SYB with class"-like query, and we can use ConstraintKinds to make the syntax a little clearer:
class Query' cls f where
gmapQm :: Monoid a => Proxy cls -> (forall t. cls t => t -> a) -> f p -> a
instance (Query' cls f) => Query' cls (M1 i c f) where
gmapQm p h (M1 x) = gmapQm p h x
instance (Query' cls f, Query' cls g) => Query' cls (f :+: g) where
gmapQm p h (L1 x) = gmapQm p h x
gmapQm p h (R1 x) = gmapQm p h x
instance (Query' cls U1) where
gmapQm _ _ U1 = mempty
instance (Query' cls f, Query' cls g) => Query' cls (f :*: g) where
gmapQm p h (f :*: g) = gmapQm p h f <> gmapQm p h g
instance (cls c) => Query' cls (K1 i c) where
gmapQm p h (K1 x) = h x
and then define multiple extensible generic queries:
class Size2 t where
size2 :: t -> Sum Int
default size2 :: (Generic t, Query' Size2 (Rep t)) => t -> Sum Int
size2 t = Sum 1 <> gmapQm #Size2 Proxy size2 (from t)
instance Size2 Something
instance (Size2 a, Size2 b) => Size2 (a,b)
instance Size2 Bool
instance Size2 Int where size2 _ = 1
instance Size2 Name where size2 (N _) = 1
class Tags t where
tags :: t -> [String]
default tags :: (Generic t, Query' Tags (Rep t)) => t -> [String]
tags t = gmapQm #Tags Proxy tags (from t)
instance Tags Something
instance (Tags a, Tags b) => Tags (a,b)
instance Tags Name where tags (N str) = ["Name", str]
instance Tags Int where tags _ = ["Int"]
instance Tags Double where tags _ = ["Double"]
instance Tags Bool where
tags True = ["Bool:True"]
tags False = ["Bool:False"]
main2 = do
print $ size2 (Something 10 (N "John", N "Doe") False)
print $ tags (Something 10 (N "John", N "Doe") False)
The full code with a bonus gmapT implementation and example:
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
import GHC.Generics
import Data.Proxy
import Data.Monoid
--
-- Size'/Size directly implemented with GHC.Generics
---
-- Handle the generic structure
class Size' f where
size' :: f p -> Int
instance (Size' f) => Size' (M1 i c f) where
size' (M1 x) = size' x
instance (Size' f, Size' g) => Size' (f :+: g) where
size' (L1 x) = size' x
size' (R1 x) = size' x
instance (Size' f, Size' g) => Size' (f :*: g) where
size' (f :*: g) = size' f + size' g
instance (Size' U1) where
size' U1 = 0
instance (Size' V1) where
size' _ = undefined
instance (Size c) => Size' (K1 i c) where
size' (K1 x) = size x
-- Handle the types
class Size t where
size :: t -> Int
default size :: (Generic t, Size' (Rep t)) => t -> Int
size t = 1 + size' (from t)
data Name = N String deriving (Show)
instance Size Name where
size (N _) = 1
-- a fanciful example of a custom recursive type
newtype Negative a = Neg a
instance Size a => Size (Negative a) where
size (Neg x) = -size x
-- a user-defined type using a default instance
data Something = Something Int (Name, Name) Bool deriving (Show, Generic)
instance Size Something
-- needs some supporting default instances:
instance Size Bool
instance (Size a, Size b) => Size (a,b)
-- and a custom instance. This could be defaulted, but
-- then we'd need an instance for unboxed Int#
instance Size Int where size _ = 1
--
-- gmapQm "with class" implemented using GHC.Generics and ConstraintKinds
--
class SYB cls f where
gmapQm :: Monoid a => Proxy cls -> (forall t. cls t => t -> a) -> f p -> a
gmapT :: Proxy cls -> (forall t. cls t => t -> t) -> f p -> f p
instance (SYB cls f) => SYB cls (M1 i c f) where
gmapQm p h (M1 x) = gmapQm p h x
gmapT p h (M1 x) = M1 $ gmapT p h x
instance (SYB cls f, SYB cls g) => SYB cls (f :+: g) where
gmapQm p h (L1 x) = gmapQm p h x
gmapQm p h (R1 x) = gmapQm p h x
gmapT p h (L1 x) = L1 $ gmapT p h x
gmapT p h (R1 x) = R1 $ gmapT p h x
instance (SYB cls U1) where
gmapQm _ _ U1 = mempty
gmapT _ _ U1 = U1
instance (SYB cls f, SYB cls g) => SYB cls (f :*: g) where
gmapQm p h (f :*: g) = gmapQm p h f <> gmapQm p h g
gmapT p h (f :*: g) = gmapT p h f :*: gmapT p h g
instance (cls c) => SYB cls (K1 i c) where
gmapQm p h (K1 x) = h x
gmapT p h (K1 x) = K1 (h x)
-- Size query using gmapQm
class Size2 t where
size2 :: t -> Sum Int
default size2 :: (Generic t, SYB Size2 (Rep t)) => t -> Sum Int
size2 t = Sum 1 <> gmapQm #Size2 Proxy size2 (from t)
instance Size2 Something
instance (Size2 a, Size2 b) => Size2 (a,b)
instance Size2 Bool
instance Size2 Int where size2 _ = 1
instance Size2 Name where size2 (N _) = 1
-- another generic query using gmapQm
class Tags t where
tags :: t -> [String]
default tags :: (Generic t, SYB Tags (Rep t)) => t -> [String]
tags t = gmapQm #Tags Proxy tags (from t)
instance Tags Something
instance (Tags a, Tags b) => Tags (a,b)
instance Tags Name where tags (N str) = ["Name", str]
instance Tags Int where tags _ = ["Int"]
instance Tags Double where tags _ = ["Double"]
instance Tags Bool where
tags True = ["Bool:True"]
tags False = ["Bool:False"]
-- a generic transform
class Zero t where
zero :: t -> t
default zero :: (Generic t, SYB Zero (Rep t)) => t -> t
zero t = to $ gmapT #Zero Proxy zero (from t)
instance Zero Something
instance (Zero a, Zero b) => Zero (a,b)
instance Zero String where zero _ = [] -- zero strings
instance Zero Name where zero = id -- but don't zero names!
instance Zero Bool where zero _ = False
instance Zero Int where zero _ = 0
instance Zero Double where zero _ = 0
-- some tests
main = do
let s = Something 10 (N "John", N "Doe") False
print $ size s
print $ size (Neg (1 :: Int, 2 :: Int), True)
print $ size2 s
print $ tags s
print $ zero (s, "this string will be zeroed")
Related
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)
In Idris, there's some magical machinery to automatically create (dependent) eliminators for user-defined types. I'm wondering if it's possible to do something (perhaps less dependent) with Haskell types. For instance, given
data Foo a = No | Yes a | Perhaps (Foo a)
I want to generate
foo :: b -> (a -> b) -> (b -> b) -> Foo a -> b
foo b _ _ No = b
foo _ f _ (Yes a) = f a
foo b f g (Perhaps c) = g (foo b f g x)
I'm pretty weak on polyvariadic functions and generics, so I could use a bit of help getting started.
Here's a start of doing this using GHC Generics. Adding some code to reassociate the (:+:) would make this nicer. A few more instances are required and this probably has ergonomic problems.
EDIT: Bah, I got lazy and fell back to a data family to get injectivity for my type equality dispatch. This mildly changes the interface. I suspect with enough trickery, and/or using injective type families this can be done without a data family or overlapping instances.
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where
import Data.Function (fix)
import GHC.Generics
data Foo a = No | Yes | Perhaps (Foo a) | Extra a Int Bool
deriving (Show, Generic1)
data Bar a = Bar (Maybe a)
deriving (Show, Generic1)
gcata :: (GCata (f a) (Rep1 f a), Generic1 f) => Alg (f a) (Rep1 f a) r -> f a -> r
gcata f = fix(\w -> gcata' w f . from1)
ex' :: Show a => Foo a -> String
ex' = gcata (("No","Yes"),(\(Rec s) -> "Perhaps ("++s++")", \a i b -> "Extra ("++show a++") ("++show i++") ("++show b++")"))
ex1 = ex' (Perhaps (Perhaps Yes) :: Foo Int)
ex2 = ex' (Perhaps (Perhaps (Extra 'a' 2 True)) :: Foo Char)
ex3 :: Foo a -> Foo a
ex3 = gcata ((No, Yes), (Perhaps . unRec, Extra))
ex4 = gcata (\(K m) -> show m) (Bar (Just 3))
class GCata rec f where
type Alg (rec :: *) (f :: *) (r :: *) :: *
gcata' :: (rec -> r) -> Alg rec f r -> f -> r
instance (GCata rec (f p)) => GCata rec (M1 i c f p) where
type Alg rec (M1 i c f p) r = Alg rec (f p) r
gcata' w f (M1 x) = gcata' w f x
instance (GCata rec (f p), GCata rec (g p)) => GCata rec ((f :+: g) p) where
type Alg rec ((f :+: g) p) r = (Alg rec (f p) r, Alg rec (g p) r)
gcata' w (l,_) (L1 x) = gcata' w l x
gcata' w (_,r) (R1 x) = gcata' w r x
instance GCata rec (U1 p) where
type Alg rec (U1 p) r = r
gcata' _ f U1 = f
instance (Project rec (f p), GCata rec (g p)) => GCata rec ((f :*: g) p) where
type Alg rec ((f :*: g) p) r = Prj rec (f p) r -> Alg rec (g p) r
gcata' w f (x :*: y) = gcata' w (f (prj w x)) y
class Project rec f where
type Prj (rec :: *) (f :: *) (r :: *) :: *
prj :: (rec -> r) -> f -> Prj rec f r
instance (Project rec (f p)) => Project rec (M1 i c f p) where
type Prj rec (M1 i c f p) r = Prj rec (f p) r
prj w (M1 x) = prj w x
instance Project rec (K1 i c p) where
type Prj rec (K1 i c p) r = c
prj _ (K1 x) = x
instance (RecIfEq (TEq rec (f p)) rec (f p)) => Project rec (Rec1 f p) where
type Prj rec (Rec1 f p) r = Tgt (TEq rec (f p)) rec (f p) r
prj w (Rec1 x) = recIfEq w x
instance Project rec (Par1 p) where
type Prj rec (Par1 p) r = p
prj _ (Par1 x) = x
instance GCata rec (K1 i c p) where
type Alg rec (K1 i c p) r = c -> r
gcata' _ f (K1 x) = f x
instance GCata rec (Par1 p) where
type Alg rec (Par1 p) r = p -> r
gcata' _ f (Par1 x) = f x
instance (Project rec (Rec1 f p)) => GCata rec (Rec1 f p) where
type Alg rec (Rec1 f p) r = Prj rec (Rec1 f p) r -> r
gcata' w f = f . prj w
data HTrue; data HFalse
type family TEq x y where
TEq x x = HTrue
TEq x y = HFalse
class RecIfEq b rec t where
data Tgt b rec t r :: *
recIfEq :: (rec -> r) -> t -> Tgt b rec t r
instance RecIfEq HTrue rec rec where
newtype Tgt HTrue rec rec r = Rec { unRec :: r }
recIfEq w = Rec . w
instance RecIfEq HFalse rec t where
newtype Tgt HFalse rec t r = K { unK :: t }
recIfEq _ = K
As pigworker remarked in the question comments, using the default Generic representation leads to great ugliness, since we don't have prior information about recursion in our type, and we have to dig out recursive occurrences by manually checking for type equality. I'd like to present here alternative solutions with explicit f-algebra-style recursion. For this, we need an alternative generic Rep. Sadly, this means we can't easily tap into GHC.Generics, but I hope this will be edifying nonetheless.
In my first solution I aim for a presentation that is as simple as possible within current GHC capabilities. The second solution is a TypeApplication-heavy GHC 8-based one with more sophisticated types.
Starting out as usual:
{-# language
TypeOperators, DataKinds, PolyKinds,
RankNTypes, EmptyCase, ScopedTypeVariables,
DeriveFunctor, StandaloneDeriving, GADTs,
TypeFamilies, FlexibleContexts, FlexibleInstances #-}
My generic representation is a fixpoint of a sum-of-products. It slightly extends the basic model of generics-sop, which is also a sum-of-products but not functorial and therefore ill-equipped for recursive algorithms. I think SOP is overall a much better practical representation than arbitrarily nested types; you can find extended arguments as to why this is the case in the paper. In short, SOP removes unnecessary nesting information and lets us separate metadata from basic data.
But before anything else, we should decide on a code for generic types. In vanilla GHC.Generics there isn't a well-defined kind of codes, as the type constructors of sums, products etc. form an ad-hoc type-level grammar, and we can dispatch on them using type classes. We adhere more closely to usual presentations in dependently typed generics, and use explicit codes, interpretations and functions. Our codes shall be of kind:
[[Maybe *]]
The outer list encodes a sum of constructors, with each inner [Maybe *] encoding a constructor. A Just * is just a constructor field, while Nothing denotes a recursive field. For example, the code of [Int] is ['[], [Just Int, Nothing]].
type Rep a = Fix (SOP (Code a))
class Generic a where
type Code a :: [[Maybe *]]
to :: a -> Rep a
from :: Rep a -> a
data NP (ts :: [Maybe *]) (k :: *) where
Nil :: NP '[] k
(:>) :: t -> NP ts k -> NP (Just t ': ts) k
Rec :: k -> NP ts k -> NP (Nothing ': ts) k
infixr 5 :>
data SOP (code :: [[Maybe *]]) (k :: *) where
Z :: NP ts k -> SOP (ts ': code) k
S :: SOP code k -> SOP (ts ': code) k
Note that NP has different constructors for recursive and non-recursive fields. This is quite important, because we want codes to be unambiguously reflected in the type indices. In other words, we would like NP to also act as a singleton for [Maybe *] (although we remain parametric in * for good reasons).
We use a k parameter in the definitions to leave a hole for recursion. We set up recursion as usual, leaving the Functor instances to GHC:
deriving instance Functor (SOP code)
deriving instance Functor (NP code)
newtype Fix f = In {out :: f (Fix f)}
cata :: Functor f => (f a -> a) -> Fix f -> a
cata phi = go where go = phi . fmap go . out
We have two type families:
type family CurryNP (ts :: [Maybe *]) (r :: *) :: * where
CurryNP '[] r = r
CurryNP (Just t ': ts) r = t -> CurryNP ts r
CurryNP (Nothing ': ts) r = r -> CurryNP ts r
type family Alg (code :: [[Maybe *]]) (r :: *) :: * where
Alg '[] r = ()
Alg (ts ': tss) r = (CurryNP ts r, Alg tss r)
CurryNP ts r curries NP ts with result type r, and it also plugs in r in the recursive occurrences.
Alg code r computes the type of an algebra on SOP code r. It tuples together the eliminators for the individual constructors. Here we use plain nested tuples, but of course HList-s would be adequate too. We could also reuse NP here as a HList, but I find that too kludgy.
All that's left is to implement the functions:
uncurryNP :: CurryNP ts a -> NP ts a -> a
uncurryNP f Nil = f
uncurryNP f (x :> xs) = uncurryNP (f x) xs
uncurryNP f (Rec k xs) = uncurryNP (f k) xs
algSOP :: Alg code a -> SOP code a -> a
algSOP fs (Z np) = uncurryNP (fst fs) np
algSOP fs (S sop) = algSOP (snd fs) sop
gcata :: Generic a => Alg (Code a) r -> a -> r
gcata f = cata (algSOP f) . to
The key point here is that we have to convert the curried eliminators in Alg into a "proper" SOP code a -> a algebra, since that is the form that can be directly used in cata.
Let's define some sugar and instances:
(<:) :: a -> b -> (a, b)
(<:) = (,)
infixr 5 <:
instance Generic (Fix (SOP code)) where
type Code (Fix (SOP code)) = code
to = id
from = id
instance Generic [a] where
type Code [a] = ['[], [Just a, Nothing]]
to = foldr (\x xs -> In (S (Z (x :> Rec xs Nil)))) (In (Z Nil))
from = gcata ([] <: (:) <: ()) -- note the use of "Generic (Rep [a])"
Example:
> gcata (0 <: (+) <: ()) [0..10]
55
Full code.
However, it would be nicer if we had currying and didn't have to use HList-s or tuples to store eliminators. The most convenient way is to have the same order of arguments as in standard library folds, such as foldr or maybe. In this case the return type of gcata is given by a type family that computes from the generic code of a type.
type family CurryNP (ts :: [Maybe *]) (r :: *) :: * where
CurryNP '[] r = r
CurryNP (Just t ': ts) r = t -> CurryNP ts r
CurryNP (Nothing ': ts) r = r -> CurryNP ts r
type family Fold' code a r where
Fold' '[] a r = r
Fold' (ts ': tss) a r = CurryNP ts a -> Fold' tss a r
type Fold a r = Fold' (Code a) r (a -> r)
gcata :: forall a r. Generic a => Fold a r
This gcata is highly (fully) ambiguous. We need either explicit application or Proxy, and I opted for the former, incurring a GHC 8 dependence. However, once we supply an a type, the result type reduces, and we can easily curry:
> :t gcata #[_]
gcata #[_] :: Generic [t] => r -> (t -> r -> r) -> [t] -> r
> :t gcata #[_] 0
gcata #[_] 0 :: Num t1 => (t -> t1 -> t1) -> [t] -> t1
> gcata #[_] 0 (+) [0..10]
55
I used above a partial type signature in [_]. We can also create a shorthand for this:
gcata1 :: forall f a r. Generic (f a) => Fold (f a) r
gcata1 = gcata #(f a) #r
Which can be used as gcata1 #[].
I'd rather not elaborate the implementation of the above gcata here. It's not much longer than the simple version, but the gcata implementation is pretty hairy (embarrassingly, it's responsible for my delayed answer). Right now I couldn't explain it very well, since I wrote it with Agda aid, which entails plenty of automatic search and type tetris.
As has been said in the comments and other answers, it's best to start from a generic representation that has access to the recursive positions.
One library that works with such a representation is multirec (another is compdata):
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs, TypeFamilies, MultiParamTypeClasses, RankNTypes #-}
module FooFold where
import Generics.MultiRec.FoldAlgK
import Generics.MultiRec.TH
data Foo a = No | Yes a | Perhaps (Foo a)
data FooF :: * -> * -> * where
Foo :: FooF a (Foo a)
deriveAll ''FooF
foldFoo :: (r, (a -> r, r -> r)) -> Foo a -> r
foldFoo phi = fold (const phi) Foo
The FoldAlgK module provides a fold with a single result type and computes the algebra type as a nested pair. It would be relatively easy to additionally curry that. There are some other variants offered by the library.
I would like to write an implementation of
instance (GMySerialize a, GMySerialize b) => GMySerialize (a :+: b)
Where GMySerialize is defined as:
class GMySerialize f where
gtoMyS :: f a -> MySerialize
gfromMyS :: MySerialize -> Maybe (f a)
That will, for any sum type consisting solely of nullary data constructors (such as data MyType = A | B | C | D | E | f), convert it to and from MySerializeInt, where MySerializeInt is a constructor for MySerialize that takes one int parameter.
I started out with
instance (GMySerialize a, GMySerialize b) => GMySerialize (a :+: b) where
gtoMyS (L1 x) = MySerializeInt (0 + rest)
where rest = case gtoMyS x of
MySerializeInt n -> n
MySerializeNil -> 0
err -> error $ show err
gtoMyS (R1 x) = MySerializeInt (1 + rest)
where rest = case gtoMyS x of
MySerializeInt n -> n
MySerializeNil -> 0
err -> error $ show err
But realised that's horribly wrong, and am not sure how to fix it. How is it wrong? As an example, the following produce the same integer, but they should not as they represent different constructors:
M1 {unM1 = L1 (R1 (M1 {unM1 = U1}))}
M1 {unM1 = R1 (L1 (M1 {unM1 = U1}))}
I'm also unsure how I'd go about writing the gfromMyS instances even if I got gtoMyS working.
To phrase it another way, what I'm looking to do has an equivalent effect to writing a Template Haskell function that generates:
instance MySerialize t where
toMyS x = MySerializeInt (toEnum x)
fromMyS (MySerializeInt n) -> Just (fromEnum n)
fromMyS _ -> Nothing
For every single t where t is sum types with only nullary constructors that implement Enum.
The trick is to make another class that counts the number of constructors
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
import Data.Functor ((<$>))
import Data.Tagged
import GHC.Generics
class GNumConstructors (f :: * -> *) where
-- Is this close enough to CAF to get memoed in the dictionary?
gnumConstructors :: Tagged f Int
instance GNumConstructors (M1 C c f) where
gnumConstructors = Tagged 1
instance (GNumConstructors a, GNumConstructors b) => GNumConstructors (a :+: b) where
gnumConstructors = Tagged $ unTagged (gnumConstructors :: Tagged a Int) + unTagged (gnumConstructors :: Tagged b Int)
Then you can easily divide up the integers between those on the left side (less than the number of possibilities on the left) and those on the right side (any larger numbers).
type MyS = Int
class GMySerialize f where
gtoMyS :: f a -> MyS
gfromMyS :: MyS -> Maybe (f a)
instance (GNumConstructors a, GMySerialize a, GMySerialize b) => GMySerialize (a :+: b) where
gtoMyS (L1 l) = gtoMyS l
gtoMyS (R1 r) = unTagged (gnumConstructors :: Tagged a Int) + gtoMyS r
gfromMyS x = if x < unTagged (gnumConstructors :: Tagged a Int)
then L1 <$> gfromMyS x
else R1 <$> gfromMyS (x - unTagged (gnumConstructors :: Tagged a Int))
Any individual constructor is represented by 0 and we peek straight through metadata.
instance GMySerialize U1 where
gtoMyS U1 = 0
gfromMyS 0 = Just U1
gfromMyS _ = Nothing
instance GMySerialize f => GMySerialize (M1 i c f) where
gtoMyS (M1 a) = gtoMyS a
gfromMyS ms = M1 <$> gfromMyS ms
Combined with a MySerialize class we can flesh out a complete example for MyType and test it
class MySerialize a where
toMyS :: a -> MyS
fromMyS :: MyS -> Maybe a
default toMyS :: (Generic a, GMySerialize (Rep a)) => a -> MyS
toMyS a = gtoMyS $ from a
default fromMyS :: (Generic a, GMySerialize (Rep a)) => MyS -> Maybe a
fromMyS a = to <$> gfromMyS a
data MyType = A | B | C | D | E | F
deriving (Generic, Show)
instance MySerialize MyType
main = do
print . map toMyS $ [A, B, C, D, E, F]
print . map (fromMyS :: MyS -> Maybe MyType) $ [-1, 0, 1, 2, 3, 4, 5, 6]
A through F are mapped to the numbers 0 through 5. Reading in those numbers reproduces A through F. Trying to read in a number outside that range produces Nothing.
[0,1,2,3,4,5]
[Nothing,Just A,Just B,Just C,Just D,Just E,Just F,Nothing]
I'm using datatype-generic programming for a class called Generic that contains a method called get. If my end user defines a type and forgets to add deriving Generic, and calls put, they will see an error message such as this:
No instance for (ALife.Creatur.Genetics.Code.BRGCWord8.GGene
(GHC.Generics.Rep ClassifierGene))
arising from a use of `ALife.Creatur.Genetics.Code.BRGCWord8.$gdmput'
I can tell users how to fix the error, but I am curious about this $gdmput. I assume it's a function or symbol that's automatically generated, but by what? Is it the use of the DefaultSignatures pragma, or the DeriveGeneric pragma? I read a few papers about datatype-generic programming, but did not see any reference to gdmXXX symbols.
Here's the definition of the Generic class.
{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances,
DefaultSignatures, DeriveGeneric, TypeOperators #-}
. . .
-- | A class representing anything which is represented in, and
-- determined by, an agent's genome.
-- This might include traits, parameters, "organs" (components of
-- agents), or even entire agents.
-- Instances of this class can be thought of as genes, i.e.,
-- instructions for building an agent.
class Genetic g where
-- | Writes a gene to a sequence.
put :: g -> Writer ()
default put :: (Generic g, GGenetic (Rep g)) => g -> Writer ()
put = gput . from
-- | Reads the next gene in a sequence.
get :: Reader (Either [String] g)
default get :: (Generic g, GGenetic (Rep g)) => Reader (Either [String] g)
get = do
a <- gget
return $ fmap to a
getWithDefault :: g -> Reader g
getWithDefault d = fmap (fromEither d) get
class GGenetic f where
gput :: f a -> Writer ()
gget :: Reader (Either [String] (f a))
-- | Unit: used for constructors without arguments
instance GGenetic U1 where
gput U1 = return ()
gget = return (Right U1)
-- | Constants, additional parameters and recursion of kind *
instance (GGenetic a, GGenetic b) => GGenetic (a :*: b) where
gput (a :*: b) = gput a >> gput b
gget = do
a <- gget
b <- gget
return $ (:*:) <$> a <*> b
-- | Meta-information (constructor names, etc.)
instance (GGenetic a, GGenetic b) => GGenetic (a :+: b) where
gput (L1 x) = putRawWord16 0 >> gput x
gput (R1 x) = putRawWord16 1 >> gput x
gget = do
a <- getRawWord16
case a of
Right x -> do
if even x -- Only care about the last bit
then fmap (fmap L1) gget
else fmap (fmap R1) gget
Left s -> return $ Left s
-- | Sums: encode choice between constructors
instance (GGenetic a) => GGenetic (M1 i c a) where
gput (M1 x) = gput x
gget = fmap (fmap M1) gget
-- | Products: encode multiple arguments to constructors
instance (Genetic a) => GGenetic (K1 i a) where
gput (K1 x) = put x
gget = do
a <- get
return $ fmap K1 a
The $gdm comes from DefaultSignatures. Here's a minimal example that produces a similar error message
{-# LANGUAGE DefaultSignatures #-}
data NoInstances = NoInstances
class Display a where
display :: a -> String
default display :: Show a => a -> String
display = show
instance Display NoInstances
The error message produced is
defaultsignatures.hs:11:10:
No instance for (Show NoInstances)
arising from a use of `Main.$gdmdisplay'
In the expression: Main.$gdmdisplay
In an equation for `display': display = Main.$gdmdisplay
In the instance declaration for `Display NoInstances'
I have two functions in my program:
getWidth :: Size -> GLint
getWidth (Size a b) = a
getXPos :: Position -> GLint
getXPos (Position a b) = a
I realized that those two functions are doing the same thing and the only difference is parameter type. Question is: how do i write such a generic function:
getFirst :: ANYTHING -> a
getFirst (ANYTHING a b) -> a
This is probably a little bit overkill for your problem, but maybe it'll be
useful for someone else that stumbles upon this question.
You can implement a truly generic function that works on any datatype that has
a single constructor with two fields by using GHC's generic programming.
Let's look at the type signature first. You'd like to write a function such as
getFirst :: ANYTHING -> a
In Haskell, a type that can be "anything" is signified with a type variable
(just like the result type a), so let's write
getFirst :: t -> a
However, having a fully polymorphic type doesn't let us operate on the type in
any way since we can't make any assumptions about its internal structure.
Therefore we need to write in some constraints about the type t.
The second thing is that a polymorphic return type (the a above) means that the
return type is inferred based on the call site, essentially meaning that the caller is able
to "request" any possible type for the first field. This is clearly impossible,
since for example for Size the only valid return type is GLint. So we need
to declare the return type so that it depends on the type t.
getFirst :: (Generic t, GPair (Rep t)) => t -> FirstT (Rep t)
Now, this is a rather complicated type signature, but the essence is that for
any type t that is generic and has a generic representation Rep t that is
a valid, generic pair (GPair), we can access the first field of the pair
which has the type FirstT (Rep t).
The type-class GPair can be defined like this
class GPair g where
type FirstT g -- type of the first field in the pair
type SecondT g -- type of the second field in the pair
gGetFirst :: g x -> FirstT g
gGetSecond :: g x -> SecondT g
This type-class introduces the function gGetFirst and gGetSecond that do not
operate on the pair type itself but its generic representation. The type
delcarations FirstT and SecondT are so called associated type synonyms that
are part of the TypeFamilies language extension. What we declare here
is that FirstT and SecondT are a synonym for some existing, unknown type
that is determined by the type g.
The generic representations of types are wrapped in meta-data descriptions that
contain information such as the data type name, constructor names, record field
names etc. We are not going to need any of that information for this case, so
the first instance of GPair simply strips out the meta-data layer.
instance GPair f => GPair (M1 i c f) where
type FirstT (M1 i c f) = FirstT f
type SecondT (M1 i c f) = SecondT f
gGetFirst = gGetFirst . unM1
gGetSecond = gGetSecond . unM1
Next we need to make an instance for the generic constuctor with two fields.
instance (GField l, GField r) => GPair (l :*: r) where
type FirstT (l :*: r) = FieldT l
type SecondT (l :*: r) = FieldT r
gGetFirst (l :*: _) = gGet l
gGetSecond (_ :*: r) = gGet r
And then we define the generic field type-class GField which operates on a
single field of the pair.
class GField g where
type FieldT g
gGet :: g x -> FieldT g
We strip out the meta-data layer from GField as we did above
instance GField f => GField (M1 i c f) where
type FieldT (M1 i c f) = FieldT f
gGet = gGet . unM1
And now we just need to add an instance for generic constructor fields.
instance GField (K1 r t) where
type FieldT (K1 r t) = t
gGet (K1 x) = x
Now we can implement the truly generic accessor functions getFirst and getSecond.
getFirst :: (Generic t, GPair (Rep t)) => t -> FirstT (Rep t)
getFirst = gGetFirst . from
getSecond :: (Generic t, GPair (Rep t)) => t -> SecondT (Rep t)
getSecond = gGetSecond . from
The function from is part of GHC.Generics and it converts a value to its
generic form. For this, the data types Size and Position need to implement
the Generic type-class.
{-# LANGUAGE DeriveGeneric #-}
data Position = Position GLInt GLInt deriving Generic
data Size = Size GLInt GLInt deriving Generic
Let's test it out:
> let sz = Size 1 2
> let pos = Position 4 6
> getFirst sz
1
> getSecond pos
6
The functions also work automatically for appropriate built-in types, such as
tuples:
> getSecond (1, "foo")
"foo"
Now, you might think that this is an awful lot of code for a simple, generic
function and that's a valid concern. However, in practice the generic instances are rather easy and quick to write once you are familiar with how the generic representation types are structured.
Also, the great thing about GHC's generic
programming is that it's completely type-safe (unlike, for example, the
reflection APIs in Java). This means that if you try to use the generic
functions with incompatible types, you get a compile time error instead of
a run-time exception.
For example:
a = getFirst (1,2,3) -- compile error because value has more than two fields
data Foo = Foo Int Int | Bar Float Float deriving Generic
b = getFirst $ Foo 1 2 -- compile error because the type has multiple constuctors
Here's the complete code for trying this out:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
import GHC.Generics
class GPair g where
type FirstT g
type SecondT g
gGetFirst :: g x -> FirstT g
gGetSecond :: g x -> SecondT g
instance GPair f => GPair (M1 i c f) where
type FirstT (M1 i c f) = FirstT f
type SecondT (M1 i c f) = SecondT f
gGetFirst = gGetFirst . unM1
gGetSecond = gGetSecond . unM1
instance (GField l, GField r) => GPair (l :*: r) where
type FirstT (l :*: r) = FieldT l
type SecondT (l :*: r) = FieldT r
gGetFirst (l :*: _) = gGet l
gGetSecond (_ :*: r) = gGet r
class GField g where
type FieldT g
gGet :: g x -> FieldT g
instance GField f => GField (M1 i c f) where
type FieldT (M1 i c f) = FieldT f
gGet = gGet . unM1
instance GField (K1 r t) where
type FieldT (K1 r t) = t
gGet (K1 x) = x
getFirst :: (Generic t, GPair (Rep t)) => t -> FirstT (Rep t)
getFirst = gGetFirst . from
getSecond :: (Generic t, GPair (Rep t)) => t -> SecondT (Rep t)
getSecond = gGetSecond . from
You need a type class (although IMO it isn't a good idea to generalize these two functions):
class Dimension d where
getX :: d -> GLint
getY :: d -> GLint
instance Dimension Size where
getX (Size x y) = x
getY (Size x y) = y
instance Dimension Position where
getX (Position x y) = x
getY (Position x y) = y
If you just want to write less code, employ record syntax:
data Size = Size { getWidth :: GLint, getHeight :: GLint }
data Position = Position { getXPos :: GLint, getYPos :: GLint }