Skip to content

Instantly share code, notes, and snippets.

@Icelandjack
Last active April 4, 2023 04:49
Show Gist options
  • Star 4 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save Icelandjack/e1ddefb0d5a79617a81ee98c49fbbdc4 to your computer and use it in GitHub Desktop.
Save Icelandjack/e1ddefb0d5a79617a81ee98c49fbbdc4 to your computer and use it in GitHub Desktop.
Newtype Deriving

wip, spin-off gists: https://gist.github.com/Icelandjack/e42495341f6029aad8c7e4e4a12c34ce

Monad gives Applicative, Applicative etc. gives Num, Floating, Fractional (regardless of actual subclass relationship)

Setting it up

WrapMonad tells us that a Monad implies Functor, Applicative

instance Monad m => Functor     (WrappedMonad m)
instance Monad m => Applicative (WrappedMonad m)
instance Monad m => Monad       (WrappedMonad m)

We can do the same with Applicative and Num (Floating, Fractional)

newtype WrapApplicative f a = WrapApplicative (f a)
  deriving (Functor, Applicative)

instance (Applicative f, Num a) => Num (WrapApplicative f a) where
  (+)         = liftA2 (+)
  (*)         = liftA2 (*)
  negate      = fmap negate
  fromInteger = pure . fromInteger
  abs         = fmap abs
  signum      = fmap signum

instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
  recip        = fmap recip
  fromRational = pure . fromRational

instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where
  pi    = pure pi
  sqrt  = fmap sqrt
  exp   = fmap exp
  log   = fmap log
  sin   = fmap sin
  cos   = fmap cos
  asin  = fmap asin
  atan  = fmap atan
  acos  = fmap acos
  sinh  = fmap sinh
  cosh  = fmap cosh
  asinh = fmap asinh
  atanh = fmap atanh
  acosh = fmap acosh

instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
  (<>) = liftA2 (<>)

instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
  mempty = pure mempty

(The uninteresting monoids of certain monads are just WrapApplicative and Alt)

Payoff

Let's take Sorted as an example

data Sorted a = Sorted a a a

If we declare a Monad instance,

{-# Language InstanceSigs #-}

instance Monad Sorted where
  return :: a -> Sorted a
  return a = Sorted a a a
  
  (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
  Sorted a b c >>= f = Sorted a' b' c' where
    Sorted a' _  _  = f a
    Sorted _  b' _  = f b
    Sorted _  _  c' = f c

WrappedMonad Sorted describes how to derive Applicative Sorted and Functor Sorted (which can be derived anyway) from that Monad Sorted instance

data Sorted a = Sorted a a a
  deriving 
    Functor
  deriving as WrappedMonad Sorted a
    Applicative

but given an Applicative we can derive Num, Fractional, Floating, Semigroup, Monoid

data Sorted a = Sorted a a a
  deriving 
    Functor
  deriving as WrappedMonad Sorted a
    Applicative
  deriving as WrappedApplicative Sorted a
    (Num, Fractional, Floating, Semigroup, Monoid)

Pretty Printing

Similar looking example from Functional Pearl: a pretty but not greedy printer from ICFP 2017

class Layout l where
  (<>)   :: l -> l -> l
  text   :: String -> l
  flush  :: l -> l
  render :: l -> String
  
instance Layout [L] where
  text     = pure . text
  flush    = fmap flush
  xs <> ys = (<>) <$> xs <∗> ys

--->

instance (Applicative f, Layout a) => Layout (WrapApplicative f a) where
  (<>)  = liftA2 (<>)
  text  = pure . text
  flush = fmap flush

Alternative to "multiple default methods"

#7395.

A silly example where we want to test if something is zero:

class IsZero a where
  isZero :: a -> Bool

a myriad of silly ways to derive this (== 0) and \a -> "0" == show a:

newtype WrappedNumEq a = WrappedNumEq a
newtype WrappedShow  a = WrappedShow  a

instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
  isZero :: WrappedNumEq a -> Bool
  isZero (WrappedNumEq a) = 0 == a
  
instance Show a => IsZero (WrappedShow a) where
  isZero :: WrappedShow a -> Bool
  isZero (WrappedShow a) = "0" == show a

hopefully this lets us choose which method we want, rather than selecting a priviledged default method:

newtype INT = INT Int 
  deriving newtype 
    Show
  deriving as WrappedShow Void
    IsZero

newtype VOID = VOID Void
  deriving as WrappedNumEq Int
    IsZero

This can be easily extended to further default methods, even given the same type

newtype WrappedNumEq2 a = WrappedNumEq2 a

instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
  isZero :: WrappedNumEq2 a -> Bool
  isZero (WrappedNumEq2 a) = a + a == a

A less-bullshit example

From monoid-subclasses

class Monoid m => MonoidNull m where
   null :: m -> Bool
newtype WrpMonNull a = WMN a

instance Monoid a => MonoidNull (WrpMonNull a) where
  null :: WrpMonNull a -> bool
  null (WMN a) = a == mempty
  
deriving via WrpMonNull ()       instance MonoidNull ()
deriving via WrpMonNull Ordering instance MonoidNull Ordering 
deriving via WrpMonNull Any      instance MonoidNull Any 

QuickCheck

Actual example where we want multiple default methods

Test.QuickCheck

arbitraryBoundedEnum          :: (Bounded a, Enum a)     => Gen a
arbitraryBoundedIntegral      :: (Bounded a, Integral a) => Gen a
arbitraryBoundedRandom        :: (Bounded a, R.Random a) => Gen a
arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a
arbitrarySizedFractional      :: Fractional a            => Gen a
arbitrarySizedIntegral        :: Integral a              => Gen a

coarbitraryEnum     :: Enum     a => a -> Gen b -> Gen b
coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b
coarbitraryReal     :: Real     a => a -> Gen b -> Gen b
coarbitraryShow     :: Show     a => a -> Gen b -> Gen b

We can replace each of those with a newtype with an Arbitrary / CoArbitrary instance

newtype ArbitraryEnum a = ArbitraryEnum a deriving (Bounded, Enum) 

instance (Bounded a, Enum a) => Arbitrary (ArbitraryEnum a) where
  arbitrary :: Gen (ArbitraryEnum a)
  arbitrary = arbitraryBoundedEnum
  
instance Enum a => CoArbitrary (ArbitraryEnum a) where
  coarbitrary :: ArbitraryEnum a -> Gen b -> Gen b
  coarbitrary = coarbitraryEnum
  
data BOOL = F | T
  deriving
    (Enum, Bounded)
  deriving as ArbitraryEnum
    (Arbitrary, CoArbitrary)

Test.QuickCheck.Function

Can be used for Test.QuickCheck.Function

import Test.QuickCheck.Function

newtype FunctionShow     a = FunctionShow     a deriving (Read, Show, Num, CoArbitrary)
newtype FunctionIntegral a = FunctionIntegral a deriving (Integral, Real, Ord, Eq, Enum, Num, CoArbitrary)
newtype FunctionRealFrac a = FunctionRealFrac a deriving (RealFrac, Real, Ord, Eq, Fractional, Num, CoArbitrary)

instance (Read a, Show a) => Function (FunctionShow a) where
  function :: (FunctionShow a -> c) -> (FunctionShow a :-> c)
  function = functionShow

instance (Integral a) => Function (FunctionIntegral a) where
  function :: (FunctionIntegral a -> c) -> (FunctionIntegral a :-> c)
  function = functionIntegral

instance RealFrac a => Function (FunctionRealFrac a) where
  function :: (FunctionRealFrac a -> c) -> (FunctionRealFrac a :-> c)
  function = functionRealFrac

to derive Function instances

data BOOL = F | T
  deriving
    (Show, Read, Enum, Bounded)
  deriving as ArbitraryEnum
    (Arbitrary, CoArbitrary)
  deriving as FunctionShow BOOL
    Function

TODO: If you could provide values to deriving instances

data BOOL = F | T
  deriving Function
    with iso (\case F -> Left  ()
                    T -> Right ())
             (\case Left  () -> F
                    Right () -> T)

Semi-Direct Product

Then the semi-direct product a ⋊ m is structurally just the product type (a, m), but under the monoid operation

(a1  m1)  (a2  m2) = (a1  (m1  a2)  m1  m2):

How to Twist Pointers without Breaking Them

"Structurally just the product type" indicates that we can use our deriving technique. It is worth noting that the maxWidth and lastWidth subcomponents of M from Functional Pearl: a pretty but not greedy printer

data M = M
  { height    :: Int
  , lastWidth :: Int
  , maxWidth  :: Int
  }

instance Layout M where
  (<>) :: M -> M -> M
  M h1 l1 m1 <..> M h2 l2 m2 = M
    (h1   +   h2)
    (l1   +   l2)
    (m1 `max` (l1 + m2))

form a semi-direct product

class (Semigroup m, Monoid m) => Action m a where
  act :: m -> a -> a

class (Action m a, Monoid a, Semigroup a) => Distributive m a

data a  b = a :⋊ b

instance Distributive m a => Semigroup (a  m) where
  (a1 :⋊ m1) <> (a2 :⋊ m2) =
    (a1 <> act m1 a2) :⋊ (m1 <> m2)

instance Distributive m a => Monoid (a  m) where
  mempty  = mempty :⋊ mempty
  mappend = (<>)

This looks confusing but it's conceptually nice

newtype LastWidth = LW (Sum Int) deriving (Show, Eq, Semigroup)
newtype MaxWidth  = MW (Max Int) deriving (Show, Eq, Semigroup)

instance Action LastWidth MaxWidth where
  act :: LastWidth -> MaxWidth -> MaxWidth
  act (LW (Sum a)) (MW (Max b)) = MW (Max (a + b))

now we we derive (<>) on M by as a Semigroup it

newtype MaxWidth  = MW Int deriving as Max Int (Show, Eq, Semigroup)
newtype LastWidth = LW Int deriving as Sum Int (Show, Eq, Semigroup)

newtype M = M_ (Sum Int, MaxWidth  LastWidth)
  deriving (Semigroup)
  
pattern M :: Int -> Int -> Int -> M
pattern M {height, maxWidth, lastWidth} = M_ (Sum height, MW maxWidth :⋊ LW lastWidth)

Wouldn't it be nice

data M = M
  { height    :: Int
  , lastWidth :: Int
  , maxWidth  :: Int
  }
  deriving as pattern M { height, lastWidth, maxWidth } = (Sum height, MW maxWidth :⋊ LW lastWidth)
    Semigroup

Dummy instances

Can be useful to satisfy constraints when you don't actually need the methods.

newtype WrapUndefined a = WrapUndefined a

instance Show (WrapUndefined a) where
  show _ = error "(GHC.Show.show): no implementation"

instance Num (WrapUndefined a) where
  _ + _ = error "(GHC.Num.+): no implementation"
  _ * _ = error "(GHC.Num.+): no implementation"

newtype BOOL = BOOL (WrapUndefined Bool)
  deriving (Show, Num)

pattern F = BOOL (WrapUndefined False)
pattern T = BOOL (WrapUndefined True)

WrappedBifunctor

-- Bitraversable 
----> Traversable
-- Bifoldable
----> Foldable

instance Bifoldable    p => Foldable      (WrappedBifunctor p a)
instance Bitraversable p => Traversable   (WrappedBifunctor p a)

and

-- Bitraversable
----> Bifunctor
----> Bifoldable

instance Bitraversable f => Bifunctor     (WrappedBitraverse f) where bimap                                 = bimapDefault
instance Bitraversable f => Bifoldable    (WrappedBitraverse f) where bifoldMap                             = bifoldMapDefault
instance Bitraversable t => Bitraversable (WrappedBitraverse t) where bitraverse f g (WrappedBitraverse xs) = WrappedBitraverse <$> bitraverse f g xs

So one could write

data P a b = P a b
  deriving as WrappedBifunctor P a b
    (Foldable, Traversable)
  deriving as WrappedBitraverse P a b
    (Bifunctor, Bifoldable)
    
instance Bitraversable P where
  bitraverse :: Applicative f => (a -> f a') -> (b -> f b') -> (P a b -> f (P a' b'))
  bitraverse f g (P a b) = P <$> f a <*> g b

A lot of things we can find with ^\#define.*\\

#define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
  (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
  (.-^) = (^-^) ; {-# INLINE (.-^) #-}
#define ADDITIVE(T) ADDITIVEC((), T)
#define id_TestData(ty) \
instance TestData ty where { \
  type Model ty = ty;        \
  model = id;                \
  unmodel = id;              \
                             \
  type EqTest ty = Property; \
  equal x y = property (x == y) }

id_TestData(())
id_TestData(Bool)
id_TestData(Int)
id_TestData(Float)
id_TestData(Double)
id_TestData(Ordering)

https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635

#define mkLattice_(x)\
instance Lattice_ x where \
    sup = (P.max) ;\
    (>=) = (P.>=) ;\
    (>) = (P.>) ;\
    {-# INLINE sup #-} ;\
    {-# INLINE (>=) #-} ;\
    {-# INLINE (>) #-}

mkLattice_(Bool)
mkLattice_(Char)
mkLattice_(Int)
mkLattice_(Integer)
mkLattice_(Float)
mkLattice_(Double)
mkLattice_(Rational)

This solves the problem of deriving multiple classes from defining a single class

Not too elegantly though, since it requires defining some ad-hoc subset of things with new names but it's a some solution at least.

class OrdShowArb a where
  cmp :: a -> a -> Ordering
  shw :: a -> String
  arb :: Gen a

instance OrdShowArb Int where
  cmp :: Int -> Int -> Ordering
  cmp = compare

  shw :: Int -> String
  shw = show

  arb  :: Gen Int
  arb = arbitrary

newtype WrappedOrdShowArb a = WrappedOrdShowArb a
  deriving OrdShowArb

instance OrdShowArb a => Eq (WrappedOrdShowArb a) where
  a == b = compare a b == EQ

instance OrdShowArb a => Ord (WrappedOrdShowArb a) where
  compare = cmp

instance OrdShowArb a => Show (WrappedOrdShowArb a) where
  show a = "default: " ++ shw a
  
instance OrdShowArb a => Arbitrary (WrappedOrdShowArb a) where
  arbitrary = arb

So now I hope to write

data A = A
  deriving (Eq, Ord, Show)
    via OrdShowArb A

instance OrdShowArb A where  
  cmp :: A -> A -> Ordering
  cmp A A = EQ
  
  shw :: A -> String
  shw A = "A"
  
  arb :: Gen A
  arb = pure A
  
newtype FOO = FOO (WrappedOrdShowArb Int) 
  deriving (Eq, Show, Ord, Arbitrary)

XX

Holy crap I don't want to define these instances, from Tower.Multiplicative

class                          MultiplicativeMagma       a where times :: a -> a -> a
class MultiplicativeMagma a => MultiplicativeUnital      a where one   :: a
class MultiplicativeMagma a => MultiplicativeCommutative a
class MultiplicativeMagma a => MultiplicativeAssociative a
class MultiplicativeMagma a => MultiplicativeInvertible  a   where recip :: a -> a

class (MultiplicativeUnital a , MultiplicativeAssociative a) => MultiplicativeMonoidal a

class (MultiplicativeCommutative a , MultiplicativeUnital a , MultiplicativeAssociative a) => Multiplicative a where
  infixl 7 *
  (*) :: a -> a -> a
  a * b = times a b

class (MultiplicativeUnital a , MultiplicativeAssociative a , MultiplicativeInvertible a) => MultiplicativeLeftCancellative a where
  infixl 7 ~/
  (~/) :: a -> a -> a
  a ~/ b = A.recip b `times` a

class (MultiplicativeUnital a , MultiplicativeAssociative a , MultiplicativeInvertible a) => MultiplicativeRightCancellative a where
  infixl 7 /~
  (/~) :: a -> a -> a
  a /~ b = a `times` A.recip b

class ( Multiplicative a , MultiplicativeInvertible a) => MultiplicativeGroup a where
  infixl 7 /
  (/) :: a -> a -> a
  a / b = a `times` A.recip b

we would define

class EVERYTHING a where
  times_  :: a -> a -> a
  one_    :: a
  recip_  :: a -> a
  (*%)    :: a -> a -> a
  (*%)     = times_
  (~/%)   :: a -> a -> a
  a~/%b    = recip_ a `times_` b
  (/~%)   :: a -> a -> a
  a/~%b    = a `times_` recip_ b
  (/%)    :: a -> a -> a
  a/%b     = a `times_` recip_ b
  
newtype WrapEVERYTHING a = WrapEVERYTHING a
  deriving EVERYTHING

instance EVERYTHING a => MultiplicativeMagma             (WrapEVERYTHING a) where times = times_
instance EVERYTHING a => MultiplicativeUnital            (WrapEVERYTHING a) where one   = one_
instance EVERYTHING a => MultiplicativeCommutative       (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeAssociative       (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeInvertible        (WrapEVERYTHING a) where recip = recip_
instance EVERYTHING a => MultiplicativeMonoidal          (WrapEVERYTHING a)
instance EVERYTHING a => Multiplicative                  (WrapEVERYTHING a) where (*) = (*%)
instance EVERYTHING a => MultiplicativeLeftCancellative  (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeRightCancellative (WrapEVERYTHING a)
instance EVERYTHING a => MultiplicativeGroup             (WrapEVERYTHING a)

and then you can derive all them classes, from defining a single instance

instance EVERYTHING Double where
  times_  :: Num a => a -> a -> a
  times_ = (Prelude.*)

  one_ :: Num a => a
  one_ = 1

  recip_ :: Fractional a => a -> a
  recip_ = Prelude.recip
  
newtype Y = Y Double
  deriving 
    ( MultiplicativeMagma, MultiplicativeUnital, MultiplicativeCommutative
    , MultiplicativeAssociative, MultiplicativeInvertible, MultiplicativeMonoidal
    , Multiplicative, MultiplicativeLeftCancellative, MultiplicativeRightCancellative)
    via WrapEVERYTHING Double

and in fact EVERYTHING could itself be defined for all Fractional

instance Fractional a => EVERYTHING a where
  times_ = (Prelude.*)
  one_   = 1
  recip_ = Prelude.recip

so we'd have to write a new newtype for this? Fun we could even derive

import Debug.SimpleReflect

newtype SR = SR Expr 
  deriving (MultiplicativeGroup)
    via WrapFractionalEVERYTHING Expr
  deriving 
    ( MultiplicativeMagma, MultiplicativeUnital, MultiplicativeCommutative
    , MultiplicativeAssociative, MultiplicativeInvertible, MultiplicativeMonoidal
    , Multiplicative, MultiplicativeLeftCancellative, MultiplicativeRightCancellative)
    via WrapEVERYTHING Expr

Aaaah holy shit, could OrdShowArb, EVERYTHING somehow be defined automatically??

Let me invent syntax for "joining" together methods of two classes

instance (Ord & Show & Arbitrary) A where  
  compare :: A -> A -> Ordering
  compare A A = EQ
  
  show :: A -> String
  show A = "A"
  
  arbitrary :: Gen A
  arb = pure A
  
instance (Ord & Show & Arbitrary) a => Eq (WrappedOrdShowArb a) where
  a == b = compare a b == EQ

instance (Ord & Show & Arbitrary) a => Ord (WrappedOrdShowArb a) where
  compare = cmp

instance (Ord & Show & Arbitrary) a => Show (WrappedOrdShowArb a) where
  show a = "default: " ++ shw a
  
instance (Ord & Show & Arbitrary) a => Arbitrary (WrappedOrdShowArb a) where
  arbitrary = arb

Everything from generic-deriving

https://hackage.haskell.org/package/generic-deriving

@Icelandjack
Copy link
Author

https://hackage.haskell.org/package/semigroupoids-5.2.1/docs/src/Data-Functor-Alt.html

class Functor f => Alt f where
  (<!>) :: f a -> f a -> f a

  some :: Applicative f => f a -> f [a]
  some v = ...

  many :: Applicative f => f a -> f [a]
  many v = ...

newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] }

instance Alt f => Alt (M1 i c f) where
  M1 f <!> M1 g = M1 (f <!> g)
  some = runMagic (unsafeCoerce (Magic some :: Magic f))
  many = runMagic (unsafeCoerce (Magic many :: Magic f))

instance Alt f => Alt (Rec1 f) where
  Rec1 f <!> Rec1 g = Rec1 (f <!> g)
  some = runMagic (unsafeCoerce (Magic some :: Magic f))
  many = runMagic (unsafeCoerce (Magic many :: Magic f))

@Icelandjack
Copy link
Author

Icelandjack commented Jan 15, 2018

https://hackage.haskell.org/package/base-4.10.1.0/docs/src/Data.Semigroup.html#line-406

instance Semigroup (Endo a) where
  (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
  stimes = stimesMonoid

instance Semigroup All where
  (<>) = coerce (&&)
  stimes = stimesIdempotentMonoid

instance Semigroup Any where
  (<>) = coerce (||)
  stimes = stimesIdempotentMonoid

instance Num a => Semigroup (Sum a) where
  (<>) = coerce ((+) :: a -> a -> a)
  stimes n (Sum a) = Sum (fromIntegral n * a)

instance Num a => Semigroup (Product a) where
  (<>) = coerce ((*) :: a -> a -> a)
  stimes n (Product a) = Product (a ^ n)

instance Semigroup a => Semigroup (Identity a) where
  (<>) = coerce ((<>) :: a -> a -> a)
  stimes n (Identity a) = Identity (stimes n a)

instance Semigroup a => Semigroup (Const a b) where
  (<>) = coerce ((<>) :: a -> a -> a)
  stimes n (Const a) = Const (stimes n a)

instance Alternative f => Semigroup (Alt f a) where
  (<>) = coerce ((<|>) :: f a -> f a -> f a)
  stimes = stimesMonoid

instance Ord a => Semigroup (Min a) where
  (<>) = coerce (min :: a -> a -> a)
  stimes = stimesIdempotent

instance Ord a => Semigroup (Max a) where
  (<>) = coerce (max :: a -> a -> a)
  stimes = stimesIdempotent

instance Applicative Min where
  pure = Min
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

instance Applicative Max where
  pure = Max
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

instance Applicative First where
  pure x = First x
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

instance Applicative Last where
  pure = Last
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

instance Monoid m => Semigroup (WrappedMonoid m) where
  (<>) = coerce (mappend :: m -> m -> m)

class Coercible1 t where
  coerce1 :: Coercion (t a) a

instance Coercible1 f => Applicative (FIRST f) where
  pure = FIRST . Coercible1
  a <* _ = a
  _ *> a = a
  (<*>) :: forall a b. FIRST f (a -> b) -> FIRST f a -> FIRST f b
  FIRST (Coercible1 f) <*> FIRST (Coercible1 a) = FIRST (Coercible1 (f a))

to_ :: forall f a. Coercible1 f => a -> f a
to_ = coerceWith $ Coerce.sym $ coerce1 @f @a

from_ :: forall f a. Coercible1 f => f a -> a
from_ = coerceWith $ coerce1 @f @a

foo :: forall f a. Coercible1 f => f a -> a
foo (Coercible1 a) = a

pattern Coercible1 :: forall f a. Coercible1 f => a -> f a 
pattern Coercible1 a <- (from_ -> a)
  where Coercible1 a = to_ a

@Icelandjack
Copy link
Author

Icelandjack commented Jan 16, 2018

Generate edge cases (nick8325/quickcheck#98)

data Foo .. deriving Arbitrary via (XTreme GenericArbitrary)

@Icelandjack
Copy link
Author

@Icelandjack
Copy link
Author

http://homepages.inf.ed.ac.uk/jmorri14/pubs/morris-hw2010-hackage.pdf

Default implementations

class XMLGen m => EmbedAsChild m c where asChild :: c -> GenChildList m

instance (EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where asChild m = asChild =<< m
instance EmbedAsChild m c => EmbedAsChild m [c] where asChild = liftM concat . mapM asChild
instance XMLGen m => EmbedAsChild m (ChildType m) where asChild = return . return
instance (XMLGen m,  XMLType m ~ x) => EmbedAsChild m x where asChild = return . return . xmlToChild
instance XMLGen m => EmbedAsChild m String where asChild = return . return . pcdataToChild
instance XMLGen m => EmbedAsChild m () where asChild _ = return []

@Icelandjack
Copy link
Author

Icelandjack commented Jan 19, 2018

http://homepages.inf.ed.ac.uk/jmorri14/pubs/morris-hw2010-hackage.pdf

lifting mtl

instance MonadState s (State s) where
    get   = State $ \s -> (s, s)
    put s = State $ \_ -> ((), s)

instance (MonadTrans t, Monad (t (State s))) 
         => MonadState s (t (State s)) where
    get   = lift $ State $ \s -> (s, s)
    put s = lift $ State $ \_ -> ((), s)

https://pdfs.semanticscholar.org/d8d0/96f207e4a7f5bf7c196359a2445bed34260f.pdf

In principle, we could avoid the quadratic growth in the number of instance declarations by defining a class MonadTrans trans with an operation

lift :: m ~> trans m

... That would permit us to write a single instance declaration

instance (IsQMonad m a, MonadTrans t) => IsQMonad (t m) a where
  addG = lift . addG
  removeG = lift removeG
  frontG = lift frontG
  isEmptyG = lift isEmptyG

to lift the queue operation through every other monad transformer. The problem with this approach is that this single instance declaration overlaps with the instance for QMonad itself. It is critical, then, that the compiler choose the right instance in each case.

@Icelandjack
Copy link
Author

There are instances that can be entirely written in terms of method_n = coerce

instance Functor Identity where
  fmap = coerce

instance Applicative Identity where
  pure = coerce
  (<*>) = coerce

instance Monad Identity where
  (>>=) = flip coerce

including "finally tagless"

class Symantics repr where
  int :: Int -> repr Int
  bool :: Bool -> repr Bool
  lam :: (repr a -> repr b) -> repr (a -> b)
  app :: repr (a -> b) -> (repr a -> repr b)

instance Symantics Identity where
  int = coerce
  bool = coerce
  lam = coerce
  app = coerce

@Icelandjack
Copy link
Author

instance Cons (ZipList a) (ZipList b) a b where
  _Cons :: Prism (ZipList a) (ZipList b) (a, ZipList a) (b, ZipList b)
  _Cons = withPrism (_Cons @[a] @[b]) $ \listReview listPreview -> 
    prism (coerce listReview) (coerce listPreview)

instance Snoc (ZipList a) (ZipList b) a b where
  _Snoc :: Prism (ZipList a) (ZipList b) (ZipList a, a) (ZipList b, b)
  _Snoc = withPrism (_Snoc @[a] @[b]) $ \listReview listPreview -> 
    prism (coerce listReview) (coerce listPreview)

@Icelandjack
Copy link
Author

Icelandjack commented Mar 4, 2018

https://github.com/rampion/tree-traversals/blob/24473aa8e7739fdac14bd1ec5b4a3c42e4f3c823/src/Data/Traversable/Tree/Binary.hs#L65 https://www.reddit.com/r/haskell/comments/81ux6k/name_that_applicative_transformer_or_let_me_tell/

newtype A a = A (Tree a) deriving (Functor, Foldable, Traversable) via PostOrder
newtype B a = B (Tree a) deriving (Functor, Foldable, Traversable) via PreOrder
newtype C a = C (Tree a) deriving (Functor, Foldable, Traversable) via InOrder
newtype D a = D (Tree a) deriving (Functor, Foldable, Traversable) via DepthOrder

@Icelandjack
Copy link
Author

https://gist.github.com/hallettj/11274639

It would be great if type class instances could be automatically derived
from isomorphism proofs.
There might be a feature along those lines that I am not aware of.

@Icelandjack
Copy link
Author

newtype Wrap (str::Symbol) f a = Wrap (f a)                                                                                                                                     
                                                                                                                                                                                
instance (KnownSymbol str, Foldable f, Show a, PrintfArg a) => Show (Wrap str f a) where                                                                                        
  show (Wrap xs) = case toList xs of                                                                                                                                            
    []      -> ""                                                                                                                                                               
    [a]     -> printf (symbolVal (Proxy::Proxy str)) a                                                                                                                          
    [a,b]   -> printf (symbolVal (Proxy::Proxy str)) a b                                                                                                                        
    [a,b,c] -> printf (symbolVal (Proxy::Proxy str)) a b c                                                                                                                      
                                                                                                                                                                                
data RGB a = RGB a a a                                                                                                                                                          
  deriving stock                                                                                                                                                                
    Foldable                                                                                                                                                                    
  deriving Show                                                                                                                                                                 
    via (Wrap "#%02X%02X%02X" RGB a)                                                                                                                                            
                                                                                                                                                                                
-- >> RGB 255 255 255                                                                                                                                                           
-- #FFFFFF                                                                                                                                                                      
-- >> RGB 35 4 0                                                                                                                                                                
-- #230400                                                                                                                                                                      

@Icelandjack
Copy link
Author

Icelandjack commented Mar 16, 2018

http://eprint.ncl.ac.uk/file_store/production/239461/EF82F5FE-66E3-4F64-A1AC-A366D1961738.pdf

similar to the col/row order

newtype Transpose g = T { transpose :: g } deriving Eq

instance Graph g => Graph (Transpose g) where
  type Vertex (Tranpose g) = Vertex g

  empty = T empty
  vertex = T . vertex
  x `overlay` y = T (transpose x `overlay` tranpose y)
  x `connect` y = T (transpose y `connect` tranpose x)

@Icelandjack
Copy link
Author

Finally Tagless http://homes.soic.indiana.edu/ccshan/tagless/jfp.pdf

type Free cls a = forall x. cls x => (a -> x) -> x

class List rep where
  list :: rep ~> Free Monoid

newtype FoldMap f a = FoldMap (f a) deriving newtype Foldable

instance Foldable f => List (FoldMap f) where
  list :: FoldMap f ~> Free Monoid
  list = flip foldMap

@Icelandjack
Copy link
Author

https://twitter.com/Iceland_jack/status/978146479285129217

class Nil  nil                where nil :: nil
class Cons cons a | cons -> a where (·) :: a -> cons -> cons

from :: [a] -> (forall list. Nil list => Cons list a => list) 
from = \case
  []   -> nil
  x:xs -> x · from xs

infixr ·
instance Nil  [a]   where nil = []
instance Cons [a] a where (·) = (:)

-- >> toList (0 · 2 · 5 · nil)
-- [0,2,5]
toList :: (forall list. Nil list => Cons list a => list) -> [a]
toList xs = xs

newtype Total = Total Int deriving newtype (Show, Num)

instance Nil  Total     where nil  = 0
instance Cons Total Int where n·ns = Total n + ns

-- >> sumList nil
-- 0
-- 
-- >> sumList (0 · 2 · 5 · nil)
-- 7
sumList :: (forall list. Nil list => Cons list Int => list) -> Int
sumList (Total n) = n

newtype Rev a = Rev [a]

instance Nil  (Rev a)   where nil        = Rev []
instance Cons (Rev a) a where a · Rev as = Rev (as ++ [a])

-- >> revList nil
-- []
--
-- >> revList (0 · 2 · 5 · nil)
-- [5,2,0]
revList :: (forall list. Nil list => Cons list a => list) -> [a]
revList (Rev xs) = xs

newtype Rev' as = Rev' as

instance Nil as => Nil (Rev' as) where nil = Rev' nil
instance Snoc as a => Cons (Rev' as) a where a·Rev' as = Rev' (snoc as a)

class    Snoc as  a | as -> a where snoc :: as -> a -> as
instance Snoc [a] a           where snoc as a = as ++ [a]

revList' :: forall a. 
  (forall list. Nil list => Cons list a => list) 
  -> 
  (forall list. Nil list => Snoc list a => list)
revList' (Rev' xs) = xs

@Icelandjack
Copy link
Author

newtype One w a = O (Maybe a, w)
  deriving 
    (Functor, Applicative, Monad, MonadFix, 
     Foldable, Alternative, MonadPlus, MonadWriter w)
    via 
    (MaybeT (Writer w))

newtype Two w a = T (Maybe (a, w))
  deriving 
    (Functor, Applicative, Monad, MonadFix, 
     Foldable, Alternative, MonadPlus, MonadWriter w)
    via 
    (WriterT w Maybe)

@Icelandjack
Copy link
Author

Icelandjack commented May 8, 2018

https://twitter.com/Iceland_jack/status/993911093763432448
https://hackage.haskell.org/package/conduit-1.2.12.1/docs/Data-Conduit.html#t:ConduitM

newtype ConduitM i o m r = ConduitM
  { unConduitM :: forall b.
                  (r -> Pipe i i o () m b) -> Pipe i i o () m b
  }
  deriving
    (Functor, Applicative, Monad, MonadIO)
  via
    (Codensity (Pipe i i o () m))

  deriving
    (MonadTrans)
  via
    (Codensity · Pipe i i o ())

where (·) comes from here

type Constr = Type -> Type

type MTrans = Constr -> Constr

newtype (·) :: MTrans -> MTrans -> MTrans where
  Comp :: t1 (t2 m) a -> (t1 · t2) m a

@Icelandjack
Copy link
Author

It helps me scan and grasp the code quicker!

@Icelandjack
Copy link
Author

Icelandjack commented May 22, 2018

I want to write http://www.cse.chalmers.se/~josefs/publications/svenningsson2015combining.pdf

data Option a = Option { isSome :: Exp Bool, fromSome :: a }
  deriving stock
    (Generic)

  deriving (Syntactic)
    via (Option a `Iso` (Exp Bool, a))

@Icelandjack
Copy link
Author

https://twitter.com/ttuegel/status/1001839454275952640

{-# Language DerivingVia #-}

import Data.Data
import Language.Haskell.TH.Syntax

newtype LiftedData a = LiftedData a
  deriving stock 
    Data

instance Data a => Lift (LiftedData a) where
  lift :: LiftedData a -> Q Exp
  lift = liftData

data V3 a = V3 a a a
  deriving stock
    Data
  deriving 
    Lift
  via
    (LiftedData (V3 a))

@Icelandjack
Copy link
Author

Icelandjack commented Jun 26, 2018

instance (Poset a, Eq (t ()), Traversable t) => Poset (t a) where
  {-# SPECIALIZE lub :: Poset a => [a] -> [a] -> [a] #-}
  lub t1 t2 = if shape t1 == shape t2 then
                fill t1 (zipWith lub (contents t1) (contents t2))
              else
                throw (NoLUBException "Control.LensFunction.lub")

from

https://bitbucket.org/kztk/app-lens/src/83376a9b25bc483c65776db48b33593601d274bd/Control/LensFunction/Core.hs?at=master&fileviewer=file-view-default

from

http://www2.sf.ecei.tohoku.ac.jp/~kztk/papers/kztk_jfp_am_2018.pdf (Applicative Bidirectional Programming: Mixing Lenses and Semantic Bidirectionalization)

@Icelandjack
Copy link
Author

http://ceur-ws.org/Vol-2115/ATAED2018-112-127.pdf

newtype Y :: ((a -> b) -> C) -> (b -> T) -> (a -> T) where
  Y :: (forall öö. cls öö => Compose f öö a)
    -> Y cls f a

-- Functor f => Functor öö => Fuctor (Compose f öö)
instance (cls ~=> Functor, Functor f, forall xx. cls xx => cls (Compose f xx)) => Functor (Y cls f) 
  where
  fmap :: (a -> a') -> (Y cls f a -> Y cls f a')
  fmap f (Y as) = Y (fmap f as)

  (<$) :: a -> Y cls f b -> Y cls f a
  a <$ Y bs = Y (a <$ bs)

newtype Y' :: ((a -> T) -> C) -> (a -> T) where
  Y' :: (forall öö. cls öö => Maybe (öö a))
     -> Y' cls a

  -- deriving (Functor)
  --   via (Y cls Maybe)

instance Functor (Y cls Maybe) => Functor (Y' cls) where
  fmap :: forall a a'. (a -> a') -> (Y' cls a -> Y' cls a')
  fmap = coerce (fmap @(Y cls Maybe) @a @a')

  (<$) :: forall a a'. a -> (Y' cls a' -> Y' cls a)
  (<$) = coerce ((<$) @(Y cls Maybe) @a @a')

@Icelandjack
Copy link
Author

{-# Language Arrows #-}

import Data.Kind
import Data.Coerce
import Control.Arrow

newtype WrapArr cat a b = WrapArr (cat a b)

newtype ArrList (cat :: Type -> Type -> Type) a = AL [a]

class Varpi (f :: s -> t) where
  type Src f :: s -> s -> Type
  type Tgt f :: t -> t -> Type

  varpa :: Src f a b 
        -> Tgt f (f a) (f b)

instance ArrowChoice cat => Varpi (ArrList cat) where
  type Src (ArrList cat) = cat
  type Tgt (ArrList cat) = cat

  varpa :: forall a b. cat a b -> cat (ArrList cat a) (ArrList cat b)
  varpa f = proc l -> case l of
    AL [] -> returnA -< AL [] 

    AL (x:xs) -> do
      y     <- f       -< x
      AL ys <- varpa f -< AL xs
      returnA -< AL (y:ys)

@Icelandjack
Copy link
Author

Taming the Parallel Effect Zoo
Extensible Deterministic Parallelism with LVish

ber generators into splittable states, and thus define a very simple
interface for random number generation, e.g.:
instance RandomGen g ⇒ SplittableState g where
splitState = System.Random.split

@Icelandjack
Copy link
Author

Icelandjack commented Oct 17, 2018

Species and Functors and Types, Oh My!

http://ozark.hendrix.edu/~yorgey/pub/species-pearl.pdf

newtype (f · g) a = Comp1 (f (g a))
newtype (f ÷ g) a = Comp2 (f (g a))
instance (Enumerable f, Enumerable g) => Enumerable (f · g) where
 enumerate :: [a] -> [(f · g) a]
 enumerate as =
   [ Comp1 fga
   | p <- partitions as
   , gs <- traverse enumerate p
   , fga <- enumerate gs 
   ]

instance (Enumerable f, Enumerable g) => Enumerable (f ÷ g) where
 enumerate :: [a] -> [(f ÷ g) a]
 enumerate = enumerate > enumerate > map Comp2

@Icelandjack
Copy link
Author

http://okmij.org/ftp/Haskell/zseq.pdf

class Sequence f where
  empty :: f a

instance Sequence f => Monoid (f a) where
  mempty = empty
  mappend = (|><|)

and

instance TSequence ooo => Category (ooo cat) 

instance TSequence seq => Sequence (AsSequence seq)
type AsSequence seq a = seq (AsUnitLoop a) '() '()

@Icelandjack
Copy link
Author

Deriving MonadState Int (State (Int, Bool)) from MonadState (Int, Bool) (State (Int, Bool)) by using a lens _1 :: Lens' (Int, Bool) Int

https://twitter.com/Iceland_jack/status/1069091766786248704

@Icelandjack
Copy link
Author

This module exports several very overlapping instances for the type classes defined in the @mtl@ library, and should be used with caution, or not at all (see the package description). The instances are defined:

http://hackage.haskell.org/package/mtl-evil-instances-0.1/docs/src/Control-Monad-Instances-Evil.html

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment