I thought join of Control.Monad had the same capability of Array.flat in JavaScript.
https://developer.mozilla.org/docs/Web/JavaScript/Reference/Global_Objects/Array/flat
However, it's against my expectation and the actual behavior is
f :: Maybe a -> Maybe a
f = \a -> join (Just a) -- works as I expected
f' :: a -> Maybe a
f' = \a -> join (Just a) -- I thought it returns Maybe a
-- Occurs check: cannot construct the infinite type: a ~ Maybe a
-- Expected type: Maybe (Maybe a)
-- Actual type: Maybe a
Is there flatten function available instead or any workaround?
join flattens always exactly two layers down to one. Ideally we would like to express something like “recursively flatten any nested layers; if we're down to one layer, don't do anything”. This would require a type like
type family Flattened x where
Flattened (m (m a)) = Flattened (m a)
Flattened (m a) = m a
flatten :: x -> Flattened x
Actually, this can't (AFAIK) be implemented as such though, we need some heavy machinery:
{-# LANGUAGE TypeFamilies, GADTs, ConstraintKinds
, MultiParamTypeClasses, FlexibleInstances
, RankNTypes, UnicodeSyntax
, ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications #-}
import Control.Monad
type family Stripped m x where
Stripped m (m a) = Stripped m a
Stripped m x = x
type Bare m x = Stripped m x ~ x
data DepthSing m x where
BareSing :: Bare m x => DepthSing m x
DeepSing :: KnownDepth m x => DepthSing m (m x)
class KnownDepth m x where
depth :: DepthSing m x
flatten :: ∀ m x . (Monad m, KnownDepth m x) => m x -> m (Stripped m x)
flatten p = case depth #m #x of
BareSing -> p
DeepSing -> flatten $ join p
instance KnownDepth m Char where
depth = BareSing
instance KnownDepth m a => KnownDepth m (m a) where
depth = DeepSing
Now
*Main> flatten (Just (Just 'v'))
Just 'v'
*Main> flatten (Just (Just (Just 'w')))
Just 'w'
*Main> flatten (Just 'i')
Just 'i'
Awkward is that we need a dedicated KnownDepth instance for every “primitive” type.
instance KnownDepth m Int where depth = BareSing
instance KnownDepth m Bool where depth = BareSing
...
Perhaps -XIncoherentInstances could help, but that's an extension I'm not touching.
A worse problem is that this doesn't work for flattening e.g. Maybe (Maybe [Int]) to Maybe [Int], we need quadratically many instances:
instance KnownDepth Maybe [x] where depth = BareSing
instance KnownDepth Maybe (Either c x) where depth = BareSing
...
instance KnownDepth [] (Maybe x) where depth = BareSing
instance KnownDepth [] (Either c x) where depth = BareSing
...
instance KnownDepth (Either c) [x] where depth = BareSing
instance KnownDepth (Either c) (Maybe x) where depth = BareSing
...
...
If you also want the behaviour 'w' -> Just 'w', this can be accomplished by
flatten' :: ∀ m x . (Monad m, KnownDepth m x) => x -> m (Stripped m x)
flatten' p = case depth #m #x of
BareSing -> return p
DeepSing -> flatten p
Related
When working with a Bifunctor, we gain access to the first and second "map" functions. So basically it is a Functor that allows us to fmap in two different ways.
Is there something like this for Monoid? Some concept that allows us to append in two different ways?
For example, imagine an opaque Matrix type. It is not a list of lists or a vector of vectors, we have no clue how it is structured inside, but we know that we can append rows and columns to it.
Would there be some type class that allowed to do this?
class X a where
firstAppend :: a -> a -> a
secondAppend :: a -> a -> a
instance X Matrix where
firstAppend = appendRow
secondAppend = appendColumn
I guess you could do something like this with indexed Monoids:
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
module IndexedMonoids where
class MonoidIx (m :: k -> *) where
type Null m :: k
type Mult m (i :: k) (j :: k) :: k
nullIx :: m (Null m)
multIx :: m i -> m j -> m (Mult m i j)
class MonoidIx2 (m :: k -> l -> *) where
type Null1 m :: k
type Null2 m :: l
type Mult1 m (i :: k) (j :: k) :: k
type Mult2 m (p :: l) (q :: l) :: l
null1Ix :: m (Null1 m) p
null2Ix :: m i (Null2 m)
mult1Ix :: m i p -> m j p -> m (Mult1 m i j) p
mult2Ix :: m i p -> m i q -> m i (Mult2 m p q)
You'd expect a bunch of laws (identity, associativity, commutativity when you put 4 blocks together). A trivial example of an indexed Monoid: the one where the index does not matter:
newtype Dummy (m :: *) (i :: k) = Dummy { getDummy :: m }
instance Monoid m => MonoidIx (Dummy m :: * -> *) where
type Null (Dummy m) = ()
type Mult (Dummy m) i j = ()
nullIx = Dummy mempty
multIx (Dummy i) (Dummy j) = Dummy $ mappend i j
I'll let you implement the instance for matrices ;)
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 am trying to design embedded language, where operations can raise certain flags depending on values. I foresee operation on scalar values as well as on vectors (e.g. map, fold, etc.) My idea is to use Writer Monad to keep track of flags. Simplified example, where actual type is "Int" and flag is raised if any of argument is 0.
import Control.Monad.Identity
import Control.Monad.Writer
import Data.Monoid
type WInt = Writer Any Int
bplus :: Int -> Int -> WInt
bplus a b =
do
tell (Any (a == 0 || b == 0)) ;
return (a+b)
wbplus :: WInt -> WInt -> WInt
wbplus wa wb =
do
a <- wa ;
b <- wb ;
tell (Any (a == 0 || b == 0)) ;
return (a+b)
ex0 = runWriter (bplus 1 2)
ex1 = runWriter (bplus 0 2)
ex2 = runWriter (wbplus (return 1) (return 2))
ex3 = runWriter (wbplus (return 0) (return 2))
ex4 = runWriter (wbplus (wbplus (return 1) (return 2)) (return 2))
ex5 = runWriter (wbplus (wbplus (return 0) (return 2)) (return 2))
ex6 = runWriter (wbplus (wbplus (return 1) (return 2)) (return 0))
I am little unsure what is the best way to implement this. Some questions:
Should I define all operations like I did for bplus or like for wbplus. Laters makes composition easier, it seems. But to use foldM binary operator should have type Int -> Int -> WInt.
What would be the appropriate type for lists: Writer Any [Int] or [Wint]?
Any suggestions or thoughts are appreciated.
You can derive bplus from wbplus and vice versa using the appropriate monadic operations:
import Control.Monad
apM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
apM2 f ma mb = do
a <- ma
b <- mb
f a b
pureM2 :: Monad m => (m a -> m b -> m c) -> a -> b -> m c
pureM2 f a b = f (return a) (return b)
They are inverses of each other, evident from the type signatures of their compositions:
ghci> :t pureM2 . apM2
pureM2 . apM2 :: Monad m => (a -> b -> m c) -> a -> b -> m c
ghci> :t apM2 . pureM2
apM2 . pureM2 :: Monad m => (m a -> m b -> m c) -> m a -> m b -> m c
Now you can define wbplus = apM2 bplus or bplus = pureM2 wbplus. There's no definite answer which one is better, use your taste and judgement. TemplateHaskell goes with the wbplus approach and defines all operations to work with values in the Q monad. See Language.Haskell.TH.Lib.
Regarding [m a] vs m [a], you can only go in one direction (via sequence :: Monad m => [m a] -> m [a]). Would you ever want to go in the opposite direction? Do you care about individual values having their own flags or would you rather annotate the computation as a whole with flags?
The real question is, what is your mental model for this? However, let's think about some consequences of each design choice.
If you choose to represent each value as Writer Any a and have all operations work with it, you can start with a newtype:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Writer
newtype Value a = Value (Writer Any a)
deriving (Functor, Applicative, Monad)
Now you can define instances of standard type classes for your
values:
instance (Num a, Eq a) => Num (Value a) where
va + vb = do
a <- va
b <- vb
(Value . tell . Any) (b == 0 || a == 0)
return (a + b)
(*) = liftM2 (*)
abs = fmap abs
signum = fmap signum
negate = fmap negate
fromInteger = return . fromInteger
instance Monoid a => Monoid (Value a) where
mempty = pure mempty
mappend = liftM2 mappend
For an EDSL this gives a huge advantage: terseness and syntactic support from the compiler. You can now write getValue (42 + 0) instead of wbplus (pure 42) (pure 0).
If, instead, you don't think about flags as a part of your values and rather see them as an external effect, it's better to go with the alternative approach. But rather than write something like Writer Any [Int], use corresponding classes from mtl: MonadWriter Any m => m [Int].
This way, if you later find out that you need to use other effects, you can easily add them to some (but not all) operations. For example, you might want to raise an error in case of division by zero:
data DivisionByZero = DivisionByZero
divZ :: (MonadError DivisionByZero m, Fractional a, Eq a) => a -> a -> m a
divZ a b
| b == 0 = throwError DivisionByZero
| otherwise = pure (a / b)
plusF :: (MonadWriter Any m, Num a, Eq a) => a -> a -> m a
plusF a b = do
tell (Any (b == 0 || a == 0))
return (a + b)
Now you can use plusF and divZ together within one monad, although they have different effects. If you'll later find yourself in need to integrate with some external library, this flexibility will come in handy.
Now, I didn't give it too much thought, but perhaps you could combine those approaches using something like newtype Value m a = Value { getValue :: m a }. Good luck exploring the design space :)
It's well known that one way of implementing Haskell typeclasses is via 'typeclass dictionaries'. (This is of course the implementation in ghc, though I make the obligatory remark that Other Implementations are Possible.) To fix ideas, I'll briefly describe how this works. A class declaration like
class (MyClass t) where
test1 :: t -> t -> t
test2 :: t -> String
test3 :: t
can be mechanically transformed into the definition of a datatype like:
data MyClass_ t = MyClass_ {
test1_ :: t -> t -> t,
test2_ :: t -> String,
test3_ :: t,
}
Then we can mechanically transform each instance declaration into an object of that type; for instance:
instance (MyClass Int) where
test1 = (+)
test2 = show
test3 = 3
turns into
instance_MyClass_Int :: MyClass_ Int
instance_MyClass_Int = MyClass_ (+) show 3
and similarly a function which has a typeclass constraint can be turned into a function that takes an extra argument; for instance:
my_function :: (MyClass t) => t -> String
my_function val = test2 . test1 test3
turns into
my_function_ :: MyClass_ t -> t -> String
my_function_ dict val = (test2_ dict) . (test1_ dict) (test3_ dict)
The point is that as long as the compiler knows how to fill in these hidden arguments (which is not totally trivial) then you can translate code that uses classes and instances into code that uses only more basic features of the language.
With that background, here's my question. I have a module M which defines a bunch of classes and functions with class constraints. M is 'opaque'; I can see what it exports (the equivalent of the .hi file) and I can import from it but I can't see its source code. I want to construct a new module N which basically exports the same things but with the transformation above applied. So for instance if M exported
class (Foo t) where
example1 :: t -> t -> t
example2 :: t -- note names and type signatures visible here
-- because they form part of the interface...
instance (Foo String) -- details of implementation invisible
instance (Foo Bool) -- details of implementation invisible
my_fn :: (Foo t) => t -> t -- exported polymorphic fn with class constraint
-- details of implementation invisible
N would start like
module N where
import M
data Foo_ t = Foo_ {example1_ :: t-> t -> t, example2_ :: t}
instance_Foo_String :: Foo_ String
instance_Foo_String = Foo_ example1 example2
instance_Foo_Bool :: Foo_ Bool
instance_Foo_Bool = Foo_ example1 example2
my_fn_ :: Foo_ t -> t -> t
my_fn_ = ???
And my question is what on earth I can put in place of the ???. In other words, what can I write to extract the 'explicit typeclass' version of the function my_fn from the original? It seems rather tricky, and it's infuriating because we all know that 'under the hood' the module M is basically already exporting something like the my_fn_ which I want to create. (Or at least, it is on GHC.)
For the record, I thought I would explain the 'hacky' solution to this which I already know of. I'll basically illustrate it using a series of examples. So let's imagine we're trying to reify the classes, instances and functions in the following (which consists mostly of pretty standard typeclasses, generally simplified somewhat for the exposition):
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Src where
import Data.List (intercalate)
class SimpleShow a where
sshow :: a -> String
class SimpleMonoid a where
mempty :: a
mappend :: a -> a -> a
class SimpleFunctor f where
sfmap :: (a -> b) -> f a -> f b
instance SimpleShow Int where
sshow = show
instance SimpleMonoid [a] where
mempty = []
mappend = (++)
instance SimpleMonoid ([a], [b]) where
mempty = ([], [])
mappend (a1, b1) (a2, b2) = (a1 ++ a2, b1 ++ b2)
instance SimpleFunctor [] where
sfmap = map
There's meant to be some generality in these examples: we have
'a' in positive position in the class member
'a' in negative position in the class member
an instance requiring flexible instances
a higher-kinded type
We leave multi-parameter type families as an exercise! Note that I do believe that what I'm presenting is a completely general, syntactic procedure; I just think it's easier to illustrate with examples than by describing the transformation formally. Anyway, let's suppose we've got the following functions to process:
show_2lists :: (SimpleShow a) => [a] -> [a] -> String
show_2lists as1 as2 = "[" ++ intercalate ", " (map sshow as1) ++ "]/["
++ intercalate ", " (map sshow as2) ++ "]"
mconcat :: (SimpleMonoid a) => [a] -> a
mconcat = foldr mappend mempty
example :: (SimpleMonoid (x, y)) => [(x, y)] -> (x, y)
example = foldr mappend mempty
lift_all :: (SimpleFunctor f) => [a -> b] -> [f a -> f b]
lift_all = map sfmap
Then the actual reification looks like:
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Main where
import Unsafe.Coerce
import Src
data Proxy k = Proxy
class Reifies s a | s -> a where
reflect :: proxy s -> a
newtype Magic a r = Magic (forall (s :: *). Reifies s a => Proxy s -> r)
reify :: forall a r. a -> (forall (s :: *). Reifies s a => Proxy s -> r) -> r
reify a k = unsafeCoerce (Magic k :: Magic a r) (const a) Proxy
{-# INLINE reify #-}
data SimpleShow_ a = SimpleShow_ {sshow_ :: a -> String}
data SimpleMonoid_ a = SimpleMonoid_ {mempty_ :: a,
mappend_ :: a -> a -> a}
data SimpleFunctor_ f = SimpleFunctor_ {
sfmap_ :: forall a b. (a -> b) -> (f a -> f b)
}
instance_SimpleShow_Int :: SimpleShow_ Int
instance_SimpleShow_Int = SimpleShow_ sshow
instance_SimpleMonoid_lista :: SimpleMonoid_ [a]
instance_SimpleMonoid_lista = SimpleMonoid_ mempty mappend
instance_SimpleMonoid_listpair :: SimpleMonoid_ ([a], [b])
instance_SimpleMonoid_listpair = SimpleMonoid_ mempty mappend
instance_SimpleFunctor_list :: SimpleFunctor_ []
instance_SimpleFunctor_list = SimpleFunctor_ sfmap
---------------------------------------------------------------------
--code to reify show_2lists :: (SimpleShow a) => [a] -> [a] -> String
-- for each type variable that occurs in the constraints, we must
-- create a newtype. Here there is only one tpye variable ('a') so we
-- create one newtype.
newtype Wrap_a a s = Wrap_a { extract_a :: a }
-- for each constraint, we must create an instance of the
-- corresponding typeclass where the instance variables have been
-- replaced by the newtypes we just made, as follows.
instance Reifies s (SimpleShow_ a) => SimpleShow (Wrap_a a s) where
--sshow :: (Wrap_ a s) -> String
sshow = unsafeCoerce sshow__
where sshow__ :: a -> String
sshow__ = sshow_ $ reflect (undefined :: [] s)
-- now we can reify the main function
show_2lists_ :: forall a. SimpleShow_ a -> [a] -> [a] -> String
show_2lists_ dict = let
magic :: forall s. ([Wrap_a a s] -> [Wrap_a a s] -> String)
-> Proxy s -> ([a] -> [a] -> String)
magic v _ arg1 arg2 = let
w_arg1 :: [Wrap_a a s]
w_arg1 = unsafeCoerce (arg1 :: [a])
w_arg2 :: [Wrap_a a s]
w_arg2 = unsafeCoerce (arg2 :: [a])
w_ans :: String
w_ans = v w_arg1 w_arg2
ans :: String
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic show_2lists)
---------------------------------------------------------------------
--code to reify mconcat :: (SimpleMonoid a) => [a] -> a
-- Here the newtypes begin with Wrap1 to avoid name collisions with
-- the ones above
newtype Wrap1_a a s = Wrap1_a { extract1_a :: a }
instance Reifies s (SimpleMonoid_ a) => SimpleMonoid (Wrap1_a a s) where
--mappend :: (Wrap1_a a s) -> (Wrap1_a a s) -> (Wrap1_a a s)
mappend = unsafeCoerce mappend__
where mappend__ :: a -> a -> a
mappend__ = (mappend_ $ reflect (undefined :: [] s))
--mempty :: (Wrap1_a a s)
mempty = unsafeCoerce mempty__
where mempty__ :: a
mempty__ = (mempty_ $ reflect (undefined :: [] s))
mconcat_ :: forall a. SimpleMonoid_ a -> [a] -> a
mconcat_ dict = let
magic :: forall s. ([Wrap1_a a s] -> (Wrap1_a a s)) -> Proxy s -> ([a] -> a)
magic v _ arg1 = let
w_arg1 :: [Wrap1_a a s]
w_arg1 = unsafeCoerce (arg1 :: [a])
w_ans :: Wrap1_a a s
w_ans = v w_arg1
ans :: a
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic mconcat)
---------------------------------------------------------------------
--code to reify example :: (SimpleMonoid (x, y)) => [(x, y)] -> (x, y)
newtype Wrap2_x x s = Wrap2_x { extract2_x :: x }
newtype Wrap2_y y s = Wrap2_y { extract2_y :: y }
instance Reifies s (SimpleMonoid_ (x, y))
=> SimpleMonoid (Wrap2_x x s, Wrap2_y y s) where
--mappend :: (Wrap2_x x s, Wrap2_y y s) -> (Wrap2_x x s, Wrap2_y y s)
-- -> (Wrap2_x x s, Wrap2_y y s)
mappend = unsafeCoerce mappend__
where mappend__ :: (x, y) -> (x, y) -> (x, y)
mappend__ = (mappend_ $ reflect (undefined :: [] s))
--mempty :: (Wrap2_x x s, Wrap2_y y s)
mempty = unsafeCoerce mempty__
where mempty__ :: (x, y)
mempty__ = (mempty_ $ reflect (undefined :: [] s))
example_ :: forall x y. SimpleMonoid_ (x, y) -> [(x, y)] -> (x, y)
example_ dict = let
magic :: forall s. ([(Wrap2_x x s, Wrap2_y y s)] -> (Wrap2_x x s, Wrap2_y y s))
-> Proxy s -> ([(x, y)] -> (x, y))
magic v _ arg1 = let
w_arg1 :: [(Wrap2_x x s, Wrap2_y y s)]
w_arg1 = unsafeCoerce (arg1 :: [(x, y)])
w_ans :: (Wrap2_x x s, Wrap2_y y s)
w_ans = v w_arg1
ans :: a
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic mconcat)
---------------------------------------------------------------------
--code to reify lift_all :: (SimpleFunctor f) => [a -> b] -> [f a -> f b]
newtype Wrap_f f s d = Wrap_f { extract_fd :: f d}
instance Reifies s (SimpleFunctor_ f) => SimpleFunctor (Wrap_f f s) where
--sfmap :: (a -> b) -> (Wrap_f f s a -> Wrap_f f s b)
sfmap = unsafeCoerce sfmap__
where sfmap__ :: (a -> b) -> (f a -> f b)
sfmap__ = sfmap_ $ reflect (undefined :: [] s)
lift_all_ :: forall a b f. SimpleFunctor_ f -> [a -> b] -> [f a -> f b]
lift_all_ dict = let
magic :: forall s. ([a -> b] -> [Wrap_f f s a -> Wrap_f f s b])
-> Proxy s -> ([a -> b] -> [f a -> f b])
magic v _ arg1 = let
w_arg1 :: [a -> b]
w_arg1 = unsafeCoerce (arg1 :: [a -> b])
w_ans :: [Wrap_f f s a -> Wrap_f f s b]
w_ans = v w_arg1
ans :: [f a -> f b]
ans = unsafeCoerce w_ans
in ans
in (reify dict $ magic lift_all)
main :: IO ()
main = do
print (show_2lists_ instance_SimpleShow_Int [3, 4] [6, 9])
print (mconcat_ instance_SimpleMonoid_lista [[1, 2], [3], [4, 5]])
print (example_ instance_SimpleMonoid_listpair
[([1, 2], ["a", "b"]), ([4], ["q"])])
let fns' :: [[Int] -> [Int]]
fns' = lift_all_ instance_SimpleFunctor_list [\ x -> x+1, \x -> x - 1]
print (map ($ [5, 7]) fns')
{- output:
"[3, 4]/[6, 9]"
[1,2,3,4,5]
([1,2,4],["a","b","q"])
[[6,8],[4,6]]
-}
Note that we use a lot of unsafeCoerce, but always relating two types that differ only in the presence of a newtype. Since the run time representations are identical, this is ok.
What you seem to be asking for is known as "local instances". This would mean that you could write something like:
my_fn_ :: forall t. Foo_ t -> t -> t
my_fn_ fooDict = let instance fooDict :: Foo t
in my_fn
Local instances are a natural extension of type classes. They were even standard in the formalism of Wadler and Blott's paper "How to make ad hoc polymorphism less ad hoc". However, they are problematic because they break a property known as principal types. Additionally, they may also break assumptions that there is only ever a single instance of a certain constraint for a specific type (like e.g. Data.Map's assumption about Ord instances). The first problem could be solved by requiring additional type annotations in a local instance and the latter is related to the controversial "orphan instances", which cause a similar problem.
Another relevant paper is Kiselyov and Shan's "Functional pearl: implicit configurations", which contains a variety of type system tricks to simulate local type instances although it doesn't really apply to your situation (pre-existing type class), IIRC.
This isn't a solution in general, but only for some special cases.
There is a hacky way to do this for class methods of a class C t that have the type parameter t appearing in a negative position in their type. e.g., example1 :: Foo t => t -> t -> t is ok, but not example2 :: Foo t => t.
The trick is to create a wrapper data type Wrapper t which comprises the explicit dictionary methods on t paired with a t value, and which has a Foo instance that exploits the appropriate wrapped dictionary methods, e.g.
data Wrapper x = Wrap {example1__ :: (x -> x -> x), val :: x}
instance Foo (Wrapper x) where
example1 (Wrap example1__ x) (Wrap _ y) = Wrap example1__ (example1__ x y)
my_fn_ :: Foo_ t -> t -> t
my_fn_ (Foo_ example1_ example2_) x = val $ my_fn (Wrap example1_ x)
Something tells me this is probably not the solution you are looking for though- it is not general purpose. In the example here, we cannot do anything with example2 because it has no negative occurrence of t with which to "sneak" functions inside. For your example, this means that my_fn in module M can use only example1.
Using type families, we can define the function fold over a type and the underlying algebra for that type represented as an n-tuple of functions and constant values. This permits the definition of a generalized foldr function, defined in the Foldable type class:
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Set as S
import qualified Data.Map as M
class Foldable m where
type Algebra m b :: *
fold :: Algebra m b -> m -> b
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = (b, a -> b -> b)
fold = uncurry $ flip S.fold
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = (b, k -> a -> b -> b)
fold = uncurry $ flip M.foldWithKey
Similarly, constraint kinds permit the definition of a generalized map function. The map function differs from fmap by considering each value field of an algebraic data type:
class Mappable m where
type Contains m :: *
type Mapped m r b :: Constraint
map :: (Mapped m r b) => (Contains m -> b) -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = a
type Mapped (Set a) r b = (Ord b, r ~ Set b)
map = S.map
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = (k, a)
type Mapped (Map k a) r b = (Ord k, r ~ Map k b)
map = M.mapWithKey . curry
From the user's perspective, neither function is particularly friendly. In particular, neither technique permits the definition of curried functions. This means that the user cannot easily apply either fold or the mapped function partially. What I would like is a type-level function that curries tuples of functions and values, in order to generate curried versions of the above. Thus, I would like to write something approximating the following type-function:
Curry :: Product -> Type -> Type
Curry () m = m
Curry (a × as) m = a -> (Curry as m b)
If so, we could generate a curried fold function from the underlying algebra. For instance:
fold :: Curry (Algebra [a] b) ([a] -> b)
≡ fold :: Curry (b, a -> b -> b) ([a] -> b)
≡ fold :: b -> (Curry (a -> b -> b)) ([a] -> b)
≡ fold :: b -> (a -> b -> b -> (Curry () ([a] -> b))
≡ fold :: b -> ((a -> b -> b) -> ([a] -> b))
map :: (Mapped (Map k a) r b) => (Curry (Contains (Map k a)) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (Curry (k, a) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (Curry (a) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (a -> Curry () b)) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (a -> b)) -> Map k a -> r
I know that Haskell doesn't have type functions, and the proper representation of the n-tuple would probably be something like a type-level length-indexed list of types. Is this possible?
EDIT: For completeness, my current attempt at a solution is attached below. I am using empty data types to represent products of types, and type families to represent the function Curry, above. This solution appears to work for the map function, but not the fold function. I believe, but am not certain, that Curry is not being reduced properly when type checking.
data Unit
data Times a b
type family Curry a m :: *
type instance Curry Unit m = m
type instance Curry (Times a l) m = a -> Curry l m
class Foldable m where
type Algebra m b :: *
fold :: Curry (Algebra m b) (m -> b)
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = Times (a -> b -> b) (Times b Unit)
fold = S.fold
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = Times (k -> a -> b -> b) (Times b Unit)
fold = M.foldWithKey
class Mappable m where
type Contains m :: *
type Mapped m r b :: Constraint
map :: (Mapped m r b) => Curry (Contains m) b -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = Times a Unit
type Mapped (Set a) r b = (Ord b, r ~ Set b)
map = S.map
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = Times k (Times a Unit)
type Mapped (Map k a) r b = (Ord k, r ~ Map k b)
map = M.mapWithKey
Ok, if I understand you correctly, you can create inconvenient folds, but want to have convenient curried folds.
Below is an explanation how to achieve this as a separate step. Yes, it can also be done all at once, I've done something similar before. However, I think the separate phase makes it clearer what's going on.
We need the following language extensions:
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
I'm using the following product and unit types:
data U = U
data a :*: b = a :*: b
infixr 8 :*:
As an example, let's assume we have an inconvenient version of a fold on lists:
type ListAlgType a r = (U -> r)
:*: (a :*: r :*: U -> r)
:*: U
inconvenientFold :: ListAlgType a r -> [a] -> r
inconvenientFold (nil :*: cons :*: U) [] = nil U
inconvenientFold a#(nil :*: cons :*: U) (x : xs) = cons (x :*: inconvenientFold a xs :*: U)
We have a nested product type, and we want to curry both levels. I'm defining two type classes for this, one for each layer. (It might be doable with one more general function, I haven't tried in this case.)
class CurryInner a where
type CurryI a k :: *
curryI :: (a -> b) -> CurryI a b
uncurryI :: CurryI a b -> a -> b
class CurryOuter a where
type CurryO a k :: *
curryO :: (a -> b) -> CurryO a b
uncurryO :: CurryO a b -> (a -> b) -- not really required here
Each type class implements the isomorphism between the curried and uncurried types. The type classes look identical, but CurryOuter will call CurryInner for each component of the outer nested tuple.
The instances are relatively straightforward:
instance CurryInner U where
type CurryI U k = k
curryI f = f U
uncurryI x = \ U -> x
instance CurryInner ts => CurryInner (t :*: ts) where
type CurryI (t :*: ts) k = t -> CurryI ts k
curryI f = \ t -> curryI (\ ts -> f (t :*: ts))
uncurryI f = \ (t :*: ts) -> uncurryI (f t) ts
instance CurryOuter U where
type CurryO U k = k
curryO f = f U
uncurryO x = \ U -> x
instance (CurryInner a, CurryOuter ts) => CurryOuter ((a -> b) :*: ts) where
type CurryO ((a -> b) :*: ts) k = CurryI a b -> CurryO ts k
curryO f = \ t -> curryO (\ ts -> f (uncurryI t :*: ts))
uncurryO f = \ (t :*: ts) -> uncurryO (f (curryI t)) ts
That's it. Note that
*Main> :kind! CurryO (ListAlgType A R) ([A] -> R)
CurryO (ListAlgType A R) ([A] -> R) :: *
= R -> (A -> R -> R) -> [A] -> R
(for suitably defined placeholder types A and R). We can use it as follows:
*Main> curryO inconvenientFold 0 (+) [1..10]
55
Edit: I now see you're actually only asking about currying the outer layer. You then only need one class, but can use the same idea. I used this example because I had written something for a sum-of-product based generic programming library which needed two levels of currying before, and thought at first you are in the same setting.
Ok, I think my other answer isn't actually really an answer to your question. Sorry for that.
In your final code, compare the types of fold and map:
fold :: Curry (Algebra m b) (m -> b)
map :: (Mapped m r b) => Curry (Contains m) b -> m -> r
There's a substantial difference here. The type of fold is just a type family application, whereas the type of map contains the final m -> r, mentioning the class parameter m. So in the case of map, it's easy for GHC to learn at which type you want to instance the class from the context.
Not so in the case of fold, unfortunately, because type families need not be injective, and therefore aren't easy to invert. So by seeing a particular type you use fold at, it's impossible for GHC to infer what m is.
The standard solution to this problem is to use a proxy argument that fixes the type of m, by defining
data Proxy m = P
and then giving fold this type instead:
fold :: Proxy m -> Curry (Algebra m b) (m -> b)
You have to adapt the instances to take and discard the proxy argument. Then you can use:
fold (P :: Proxy (Set Int)) (+) 0 (S.fromList [1..10])
or similar to call the fold function on sets.
To see more clearly why this situation is difficult for GHC to solve, consider this toy example instead:
class C a where
type F a :: *
f :: F a
instance C Bool where
type F Bool = Char -> Char
f = id
instance C () where
type F () = Char -> Char
f = toUpper
Now, if you call f 'x', there's no meaningful way for GHC to detect which instance you meant. The proxy would help here as well.
A type-level list is exactly what you need! You got very close, but you need the full power of both DataKinds and ScopedTypeVariables for this to work properly:
{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
import GHC.Exts (Constraint)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Set as S
import qualified Data.Map as M
-- | A "multifunction" from a list of inhabitable types to an inhabitable type (curried from the start).
type family (->>) (l :: [*]) (y :: *) :: *
type instance '[] ->> y = y
type instance (x ': xs) ->> y = x -> (xs ->> y)
class Foldable (m :: *) where
type Algebra m (b :: *) :: [*]
fold :: forall (b :: *). Algebra m b ->> (m -> b)
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = '[(a -> b -> b), b]
fold = S.fold :: forall (b :: *). (a -> b -> b) -> b -> Set a -> b
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = '[(k -> a -> b -> b), b]
fold = M.foldWithKey :: forall (b :: *). (k -> a -> b -> b) -> b -> Map k a -> b
class Mappable m where
type Contains m :: [*]
type Mapped m (b :: *) (r :: *) :: Constraint
map :: forall (b :: *) (r :: *). Mapped m b r => (Contains m ->> b) -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = '[a]
type Mapped (Set a) b r = (Ord b, r ~ Set b)
map = S.map :: forall (b :: *). (Ord b) => (a -> b) -> Set a -> Set b
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = '[k, a]
type Mapped (Map k a) b r = r ~ Map k b
map = M.mapWithKey :: forall (b :: *). (k -> a -> b) -> Map k a -> Map k b