Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented May 27, 2017

This question on r/purescript, we can derive most of the functionality but Foldable1 and Traversable1 are not possible since Const a is neither:

newtype Ann a f b = ANN (Product (Const a) f b)
  deriving (Show, Functor, Applicative, Foldable, Traversable)

class Foldable f => Foldable1 f where
  foldMap1 :: Semigroup m => (a -> m) -> (f a -> m)

instance Foldable1 f => Foldable1 (Ann a f) where
  foldMap1 :: Semigroup m => (b -> m) -> (Ann a f b -> m)
  foldMap1 f (Ann _ fb) = foldMap1 f fb

instance Traversable1 f => Traversable1 (Ann a f) where
  traverse1 :: Apply ap => (b -> ap b') -> (Ann a f b -> ap (Ann a f b'))
  traverse1 f (Ann a fb) = Ann a <$> traverse1 f fb

{-# COMPLETE Ann #-}
pattern Ann :: a -> f b -> Ann a f b
pattern Ann a b = ANN (Pair (Const a) b)

?: in the interest of being able to derive as many things as possible, should this type be given a name or is there a smaller building block that lets you derive this. Maybe

type SNDPRODUCT val f a = Product (Const val) f a

data SndProduct val f a = val :--> g a
  deriving (Functor, Foldable, Traversable)

instance Foldable1 f => Foldable1 (SndProduct val f) where
  foldMap1 :: Semigroup m => (a -> m) -> (SndProduct val f a -> m)
  foldMap1 f (_ :--> fa) = foldMap1 f fa

instance Traversable1 f => Traversable1 (SndProduct val f) where
  traverse1 :: Apply ap => (a -> ap a') -> (SndProduct val f a -> ap (SndProduct val f a'))
  traverse1 f (val :--> fa) = (val :-->) <$> traverse1 f fa

all other instances could ideally be derived via Product (Const val) f a. This simplifies adding new points to the design space. An alternative is privileging one side over the other in the type class instance

instance (Const val ~ f, Foldable1    g) => Foldable1    (Product f g) where
instance (Const val ~ f, Traversable1 g) => Traversable1 (Product f g) where

but this overlaps with the existing one... reminds me of Applicative (Sum f g)

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented May 27, 2017

Good direction ekmett/semigroupoids#55

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented May 27, 2017

Excellent example of different reps https://www.reddit.com/r/purescript/comments/4jhcvv/question_applicative_functors_annotated_by_a/

-- You
data Ann a f b = Ann a (f b)

-- That representation she told you not to worry about
Ann val = Compose (val, ) 
Ann val = Product (Const val) 

Now just diff the instances we get

@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 4, 2017

? What are the limits: https://hackage.haskell.org/package/transformers-base-0.4.4/docs/src/Control-Monad-Base.html

liftBaseDefault  (MonadTrans t, MonadBase b m)  b α  t m α
liftBaseDefault = lift . liftBase

#define TRANS(T) \
instance (MonadBase b m)  MonadBase b (T m) where liftBase = liftBaseDefault

#define TRANS_CTX(CTX, T) \
instance (CTX, MonadBase b m)  MonadBase b (T m) where liftBase = liftBaseDefault

and

https://hackage.haskell.org/package/monad-control-1.0.1.0/docs/src/Control-Monad-Trans-Control.html#StM

#define BASE(M)                           \
instance MonadBaseControl (M) (M) where { \
    type StM (M) a = a;                   \
    liftBaseWith f = f id;                \
    restoreM = return;                    \
    {-# INLINABLE liftBaseWith #-};       \
    {-# INLINABLE restoreM #-}}

#define BODY(T) {                         \
    type StM (T m) a = ComposeSt (T) m a; \
    liftBaseWith = defaultLiftBaseWith;   \
    restoreM     = defaultRestoreM;       \
    {-# INLINABLE liftBaseWith #-};       \
    {-# INLINABLE restoreM #-}}

#define TRANS(         T) \
  instance (     MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T)
#define TRANS_CTX(CTX, T) \
  instance (CTX, MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T)

btw liftBaseWith :: (RunInBase m b -> b a) -> m a is liftBaseWith :: Ran b m (RunInBase m b) https://hackage.haskell.org/package/kan-extensions-5.0.2/docs/Data-Functor-Kan-Ran.html

@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 4, 2017

#define SUBCLASS(X,Y)\
        instance Fact (X :⊆: Y) where\
            auto = Subset (\ X -> Y )
               

SUBCLASS(OrdType,EqType)
SUBCLASS(NumType,EqType)
SUBCLASS(IntegralType,NumType)
SUBCLASS(MonadPlusType,MonadType)

https://hackage.haskell.org/package/type-settheory-0.1.3.1/docs/src/Type-Set.html

@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 4, 2017

https://hackage.haskell.org/package/cipher-aes-0.2.11/docs/src/Crypto-Cipher-AES.html

#define INSTANCE_BLOCKCIPHER(CSTR) \
instance BlockCipher CSTR where \
    { blockSize _ = 16 \
    ; ecbEncrypt (CSTR aes) = encryptECB aes \
    ; ecbDecrypt (CSTR aes) = decryptECB aes \
    ; cbcEncrypt (CSTR aes) = encryptCBC aes \
    ; cbcDecrypt (CSTR aes) = decryptCBC aes \
    ; ctrCombine (CSTR aes) = encryptCTR aes \
    ; xtsEncrypt (CSTR aes1, CSTR aes2) = encryptXTS (aes1,aes2) \
    ; xtsDecrypt (CSTR aes1, CSTR aes2) = decryptXTS (aes1,aes2) \
    ; aeadInit AEAD_GCM cipher@(CSTR aes) iv = Just $ AEAD cipher $ AEADState $ gcmInit aes iv \
    ; aeadInit AEAD_OCB cipher@(CSTR aes) iv = Just $ AEAD cipher $ AEADState $ ocbInit aes iv \
    ; aeadInit _        _                  _ = Nothing \
    }; \
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 18, 2017

https://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Bits.html#v:popCountDefault

Now this is interesting, here we are dealing with only a subset of methods right?

bitDefault      :: (Bits a, Num a) => Int -> a
testBitDefault  :: (Bits a, Num a) => a -> Int -> Bool
popCountDefault :: (Bits a, Num a) => a -> Int

but you really need a subset of a type class

{-# Language GeneralizedNewtypeDeriving #-}

import Data.Bits

class Bits' a where
  (.&&.)        :: a -> a -> a
  (.||.)        :: a -> a -> a
  xor'          :: a -> a -> a
  complement'   :: a -> a
  shift'        :: a -> Int -> a
  rotate'       :: a -> Int -> a
  bitSize'      :: a -> Int
  bitSizeMaybe' :: a -> Maybe Int
  isSigned'     :: a -> Bool

newtype WrappedBits a = WrapBits a
  deriving (Bits', Eq, Num)

instance (Eq a, Num a, Bits' a) => Bits (WrappedBits a) where
  (.&.)        = (.&&.)
  (.|.)        = (.||.)
  xor          = xor'
  complement   = complement'
  shift        = shift'
  rotate       = rotate'
  bitSize      = bitSize'
  bitSizeMaybe = bitSizeMaybe'
  isSigned     = isSigned'

  testBit      = testBitDefault
  bit          = bitDefault
  popCount     = popCountDefault

which is obviously annoying to write out

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 18, 2017

So with this, maybe we could do something radical and define with hand-wavey

type Bits = (:.&.) & (:.|.) & Xor & Complement & Shift & Rotate & ZeroBits & Bit & SetBit & ClearBit & ComplementBit & TestBit & BitSize & BitSizeMaybe & IsSigned & ShiftL & UnsafeShiftL & ShiftR & UnsafeShiftR & RotateL & RotateR & PopCount

I don't love it, but it lets you define

type Bits' = (:.&.) & (:.|.) & Xor & Complement & Shift & Rotate & BitSize & BitSizeMaybe & IsSigned

instance Bits' B where
  (.&.) = ...
  (.|.) = ..
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 19, 2017

https://hackage.haskell.org/package/kan-extensions-5.0.2/docs/Control-Monad-Co.html

Having a Comonad gives you Applicative, MonadTrans, Monad, MonadIO, ...

@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 28, 2017

This is a start for working over multiple representations

class From b a => From a b where
  from :: a -> b

instance From (a, a) (a, a) where
  from :: (a, a) -> (a, a)
  from = id

instance From (a, a) (Bool -> a) where
  from :: (a, a) -> (Bool -> a)
  from (a, b) = \case
    False -> a
    True  -> b

instance From (Bool -> a) (a, a) where
  from :: (Bool -> a) -> (a, a)
  from f = (f False, f True)

instance From (a, a) (Product Identity Identity a) where
  from :: (a, a) -> Product Identity Identity a
  from (a, b) = Identity a `Pair` Identity b

instance From (Product Identity Identity a) (a, a) where
  from :: Product Identity Identity a -> (a, a)
  from (Identity a `Pair` Identity b) = (a, b)

data SomeRep a where
  D1 :: (a, a)                      -> SomeRep a
  D2 :: (Bool -> a)                 -> SomeRep a
  D3 :: Product Identity Identity a -> SomeRep a

instance Foldable SomeRep where
  foldMap f = \case
    D1 (a, b)                           -> f a `mappend` f b
    D2 fun                              -> f (fun False) `mappend` f (fun True)
    D3 (Pair (Identity a) (Identity b)) -> f a `mappend` f b

instance Foldable1 SomeRep where
  foldMap1 :: forall a m. Semigroup m => (a -> m) -> (SomeRep a -> m)
  foldMap1 f = \case
    D1 (a :: (a, a)) -> a'' where
      a' :: Product Identity Identity a
      a' = from a

      a'' :: m
      a'' = foldMap1 f a'

    D2 (b :: Bool -> a) -> b''' where
      b' :: (a, a)
      b' = from b

      b'' :: Product Identity Identity a
      b'' = from b'

      b''' :: m
      b''' = foldMap1 f b''

    D3 c -> foldMap1 f c

roundtrip :: forall a b c. (From a b, From b c) => a -> c
roundtrip (a :: a) = from (from a :: b)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jun 28, 2017

roundtrip :: forall a b c. (From a b, From b c) => a -> c
roundtrip (a :: a) = from (from a :: b)

poop :: forall a b c. (From a (b, b), From (b, b) c) => a -> c
poop = roundtrip @_ @(b, b)

d1 :: forall a t.
       ((a, a) -> t)
    -> (SomeRep a -> t)
d1 f = \case
  D1 (poop @_ @a -> a) -> f a
  D2 (poop @_ @a -> a) -> f a
  D3 (poop @_ @a -> a) -> f a

d2 :: forall a t.
       ((Bool -> a) -> t)
    -> (SomeRep a -> t)
d2 f = \case
  D1 (poop @_ @a -> a) -> f a
  D2 (poop @_ @a -> a) -> f a
  D3 (poop @_ @a -> a) -> f a

d3 :: forall a t.
       (Product Identity Identity a -> t)
    -> (SomeRep a -> t)
d3 f = \case
  D1 (poop @_ @a -> a) -> f a
  D2 (poop @_ @a -> a) -> f a
  D3 (poop @_ @a -> a) -> f a
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 10, 2017

We can get Strong & Choice from Traversing

firstTraversing  :: Traversing p => p a b -> p (a, c) (b, c)
secondTraversing :: Traversing p => p a b -> p (c, a) (c, b)
leftTraversing   :: Traversing p => p a b -> p (Either a c) (Either b c)
rightTraversing  :: Traversing p => p a b -> p (Either c a) (Either c b)

We can presumably write

newtype WrappedTraversing p a b = WrapTraversing (p a b)
  deriving (Profunctor, Traversing)

instance Traversing p => Strong (WrappedTraversing p) where
  first' :: WrappedTraversing p a b -> WrappedTraversing p (a, xx) (b, xx)
  first'  = firstTraversing

  second' :: WrappedTraversing p a b -> WrappedTraversing p (xx, a) (xx, b)
  second' = secondTraversing

instance Traversing p => Choice (WrappedTraversing p) where
  left' :: WrappedTraversing p a b -> WrappedTraversing p (Either a xx) (Either b xx)
  left'  = leftTraversing

  right' :: WrappedTraversing p a b -> WrappedTraversing p (Either xx a) (Either xx b)
  right' = rightTraversing
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 10, 2017

Mapping gives us Traversing and Choice

newtype WrappedMapping p a b = WrapMapping (p a b)
  deriving (Profunctor, Mapping, Strong, Choice)

instance Mapping p => Traversing (WrappedMapping p) where
  traverse' :: Functor f => WrappedMapping p a b -> WrappedMapping p (f a) (f b)
  traverse' = traverseMapping

instance Mapping p => Closed (WrappedMapping p) where
  closed :: WrappedMapping p a b -> WrappedMapping p (xx -> a) (xx -> b)
  closed = closedMapping

Can be used withWrapTraversing

synergy

newtype Ör a b = Ör { getÖr :: a -> b }
  deriving newtype 
    Profunctor

deriveVia ''Choice ''Ör ''WrappedTraversing
deriveVia ''Strong ''Ör ''WrappedTraversing
deriveVia ''Traversing ''Ör ''WrappedMapping
-- Actually we need this because of blergh
-- instance Traversing Ör where
--   traverse' :: forall f a b. Traversable f => Ör a b -> Ör (f a) (f b)
--   traverse' = coerce (traverse' @(->) @f @a @b)
deriveVia ''Closed     ''Ör ''WrappedMapping

instance Mapping Ör where
  map' :: Functor f => Ör a b -> Ör (f a) (f b)
  map' (Ör f) = Ör (fmap f) 

Doesn't this look sweet?

newtype F a b = ...
  deriving via WrappedTraversing
    (Choice, Strong)
  deriving via WrappedMapping
    (Traversing, Closed)

instance Profunctor F 
instance Mapping F
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 10, 2017

A Representable profunctor gives us Strong

firstRep  :: Representable p => p a b -> p (a, c) (b, c)
secondRep :: Representable p => p a b -> p (c, a) (c, b)

and a Corepresentable gives Costrong and Closed

unfirstCorep  :: Corepresentable p => p (a, d) (b, d) -> p a b
unsecondCorep :: Corepresentable p => p (d, a) (d, b) -> p a b
closedCorep   :: Corepresentable p => p a b -> p (x -> a) (x -> b)

Instances for those modifiers is trickier in GHC < 8 (which is what I have at work) so I'll fill them out later.


Maybe one day we can derive Sieve :)

newtype W p a b = W (p a b)
  deriving newtype 
    (Profunctor, Representable)

instance (Profunctor p, Functor (Rep p), p' ~ Rep p) => Sieve (W p) p' where
  sieve :: forall a b. W p a b -> (a -> p' b)
  sieve = coerce
    (sieve @(W p) @(Rep p) @a @b)

instance Representable p => Strong (W p) where
  first'  = firstRep
  second' = secondRep
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 10, 2017

Don't just focus on WrappedArrow (also Star), also notice newtypes such as Forget

newtype Forget r a b = Forget (a -> r)

Profunctor (Forget r)
Strong (Forget r)
Monoid r => Choice (Forget r)	 
Representable (Forget r)
Sieve (Forget r) (Const * r)
Functor (Forget r a)
Foldable (Forget r a)	 
Traversable (Forget r a)
type Rep (Forget r)

This is an interesting character and we get stuff like this

newtype Foo a b = Foo { unFoo :: a -> String }

instance Profunctor Foo where
  dimap :: forall a a' b b'. (a' -> a) -> (b -> b') -> (Foo a b -> Foo a' b')
  dimap = coerce (dimap @(Forget String) @a' @a @b @b')

instance Choice Foo where
  left' :: forall a a' xx. Foo a a' -> Foo (Either a xx) (Either a' xx)
  left'  = coerce (left' @(Forget String) @a @a' @xx)

  right' :: forall b b' xx. Foo b b' -> Foo (Either xx b) (Either xx b')
  right'  = coerce (right' @(Forget String) @b @b' @xx)
>>> unFoo (left' (Foo show)) (Left pi)
"3.141592653589793"
>>> unFoo (left' (Foo show)) (Right ())
""

Hopefully we get

newtype a ~> b = Arr (a -> String)
  deriving via (Forget String)
    (Profuntor, Strong, Choice, Representable, Functor, Foldable, Traversable)

and since Sieve needs to be kind of flipped..

    (..., Sieve _₁ (Const String), ...)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

Overlapping stuff

type Flay c s t f g = forall m. Applicative m => (forall a. Dict (c a) -> f a -> m (g a)) -> s -> m t

class Flayable (c :: * -> Constraint) s t f g | s -> f, t -> g, s g -> t, t f -> s where
  flay ::  Flay c s t f g

instance {-# OVERLAPPABLE #-} c a => Flayable c (f a) (g a) f g where
  flay = \h fa -> h Dict fa

(except the rank-2 type cannot be coerced) we could create a newtype wrapper for the overlapping instance, for this simpler example

class Foo x y xs ys where
  map_ :: (x -> y) -> (xs -> ys)

newtype WrappedFoo f x = WrapFoo (f x)

instance Functor f => Foo x y (WrappedFoo f x) (WrappedFoo f y) where
  map_ f (WrapFoo xs) = WrapFoo (fmap f xs)

instance Foo x y [x] [y] where
  map_ :: (x -> y) -> ([x] -> [y])
  map_ = coerce (map_ :: (x -> y) -> (WrappedFoo [] x -> WrappedFoo [] y))

instance Foo x y (Maybe x) (Maybe y) where
  map_ :: (x -> y) -> (Maybe x -> Maybe y)
  map_ = coerce (map_ :: (x -> y) -> (WrappedFoo Maybe x -> WrappedFoo Maybe y))

I haven't thought how this works for deriving syntax though

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

For more examples just search Overlappable

instance {-# OVERLAPPABLE #-} (Semiring a) => Num a where
  (+) = add
  (*) = mul
  negate = (*) (-1)
  abs = id
  signum = const 1
  fromInteger = fst . char

becomes

class Semiring a where
  zero :: a
  char :: Integer -> (a, Integer)

  add :: a -> a -> a
  mul :: a -> a -> a

instance Semiring Word where
  zero = 0
  char n = (x, n `shiftR` finiteBitSize x)
    where x = fromInteger n

  add = (+)
  mul = (*)

newtype WrappedSemiring a = WrapSemiring a
  deriving
    Semiring

instance Semiring a => Num (WrappedSemiring a) where
  (+) = add
  (*) = mul
  negate = (*) (-1)
  abs = id
  signum = const 1
  fromInteger = fst . char

deriving instance via WrappedSemiring (Num Word) -- as if it didn't have it before
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

https://github.com/serokell/universum/blob/ef6b29847eb73c047a01082d4bcf656a2233e9a3/src/Containers.hs

class Container xs where
  type Element xs

  toList :: xs -> [Element xs]
  null   :: xs -> Bool

newtype WrappedContainer xs = WrapContainer xs

instance Foldable.Foldable f => Container (WrappedContainer (f a)) where
  type Element (WrappedContainer (f a)) = a

  toList :: WrappedContainer (f a) -> [a]
  toList (WrapContainer fs) = Foldable.toList fs

  null :: WrappedContainer (f a) -> Bool
  null (WrapContainer fa) = Foldable.null fa

instance Container [a] where
  type Element [a] = a

  toList :: [a] -> [a]
  toList = coerce (toList :: WrappedContainer [a] -> [a])

  null :: [a] -> Bool
  null = coerce (null :: WrappedContainer [a] -> Bool)
deriving instance via WrappedContainer (Container [a])
deriving instance via WrappedContainer (Container (Maybe a))
deriving instance via WrappedContainer (Container (Either a b))

data V3 a = V3 a a a 
  deriving stock
    Foldable
  deriving via WrappedContainer
    Container
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

Similarly as Arbitrary https://github.com/plneappl/HasKlax/blob/ce54ad07097e85c8c6a920adfa19b1b70f1eeb54/src/Lib.hs

instance {-# OVERLAPPABLE #-} (Enum a, Bounded a) => Random a where
  randomR (mn, mx) r = let
    (res, r') = randomR (fromEnum mn, fromEnum mx) r in
    (toEnum res, r')
  random = randomR (minBound, maxBound)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 12, 2017

https://github.com/Airini/FEECa/blob/8b56de0072e0bceb0aa7be5d09db5b05daf43a55/src/FEECa/Internal/Spaces.hs

instance Ring Integer where
  add     = (+)
  addId   = 0
  addInv  = negate
  mul     = (*)
  mulId   = 1
  embedIntegral = fromIntegral
  pow     = (^)

instance Ring Rational where
  add     = (+)
  addId   = 0
  addInv  = (0-)
  mul     = (*)
  mulId   = 1
  pow     = (^)
  embedIntegral = fromIntegral
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 13, 2017

http://hackage.haskell.org/package/derive

and

https://ghc.haskell.org/trac/ghc/ticket/13403

-- Applicative
genericPure :: (Generic1 f, Applicative (Rep1 f))
            => a -> f a
genericPure = to1 . pure

genericAp :: (Generic1 f, Applicative (Rep1 f))
          => f (a -> b) -> f a -> f b
genericAp f x = to1 $ from1 f <*> from1 x

-- Monad
genericBind :: (Generic1 m, Monad (Rep1 m))
            => m a -> (a -> m b) -> m b
genericBind m f = to1 $ from1 m >>= from1 . f

-- Example
data Product f g h a = Product (f (g (f a))) (h (f (g a)))
  deriving (Functor, Generic1)
instance (Applicative f, Applicative g, Applicative h)
    => Applicative (Product f g h) where
  pure  = genericPure
  (<*>) = genericAp
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 18, 2017

https://www.schoolofhaskell.com/user/edwardk/moore/for-less

how many instances can we squeeze from the Fix, probably not many

data Moore a b = Moore b (a -> Moore a b)
-- ~ 
data Cofree f a = Cofree a (f (Cofree f a))
type Moore a b = Cofree ((->) a) b
-- ~ 
Cofree f a = Fix (Compose ((,) a) f)
type Moore a b = Fix (Compose ((,) b) ((->) a))
type Moore a b = Fix ((b, ) :.: (a ->))
newtype Fix p b = In (p (Fix p b) b)

-- Profunctor Forget
newtype Remember r a b = Member (r -> a)

type Moore a b = Fix (Product (Joker Identity) (Remember a)) b
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 19, 2017

https://hackage.haskell.org/package/representable-functors-3.2.0.2/docs/Data-Functor-Contravariant-Representable.html

contramapDefault :: Representable f => (a -> b) -> f b -> f a
contramapWithValueDefault :: Representable f => (b -> Either a (Value f)) -> f a -> f b

nothing spectacular

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 19, 2017

https://hackage.haskell.org/package/semigroupoids-5.2/docs/src/Data-Semigroup-Foldable.html except it doesn't export

newtype Act f a = Act { getAct :: f a }

instance B.Apply f => Semigroup (Act f a) where
  Act a <> Act b = Act (a B..> b)

newtype Foo a = Foo (Maybe a)
  deriving newtype
    (Functor, B.Apply)
deriveVia ''Semigroup ''Foo ''Act 

and https://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Monoid.html#t:Alt

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 19, 2017

newtype JoinWith a = JoinWith {joinee :: (a -> a)}

instance Semigroup a => Semigroup (JoinWith a) where
  JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 23, 2017

Every right adjoint is representable by its left adjoint applied to a unit element.

https://hackage.haskell.org/package/adjunctions-4.3/docs/Data-Functor-Adjunction.html

newtype WrappedF (f :: Type -> Type) u a = WrapF (u a)
  deriving Functor

instance Adjunction f u => Distributive (WrappedF f u) where
  distribute = distributeRep

instance Adjunction f u => Representable (WrappedF f u) where
  type Rep (WrappedF f u) = f ()

  index :: WrappedF f u a -> (f () -> a)
  index (WrapF ua) = indexAdjunction ua

  tabulate :: (f () -> a) -> WrappedF f u a
  tabulate f = WrapF (tabulateAdjunction f)

and I want to be able to recover

instance Adjunction CoordF Board where
  unit :: a -> Board (CoordF a)
  unit a = tabulate (\(CoordF row col ()) -> CoordF row col a)

  counit :: CoordF (Board a) -> a
  counit (CoordF row col board) = index board (CoordF row col ())

from http://chrispenner.ca/posts/adjunction-battleship given that

-- (,) (E V3, E V3) a
data CoordF a = CoordF Row Column a

-- Compose V3 V3 a
data Board a 
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 23, 2017

todo

I want to be able to derive Representable Board (with Rep Board = CoordF ().. or even cooler with newtype Coord = Coord_ (CoordF ()) and Rep Board = Coord) from an adjunction between CoordF and Board.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 23, 2017

todo

I also want this

newtype Pair_ish f b = Pair_ish (Rep f, b) deriving newtype (Functor)
newtype Arr_ish  f b = Arr_ish (f b)      
  deriving newtype 
    (Functor, Representable)

instance Representable f => Distributive (Arr_ish f) where
  distribute = distributeRep

-- Adjunction (Rep f, ) f
instance Representable f => Adjunction (Pair_ish f) (Arr_ish f) where
  unit :: a -> Arr_ish f (Pair_ish f a)
  unit a = Arr_ish (tabulate (\b -> Pair_ish (b, a)))

  counit :: Pair_ish f (Arr_ish f a) -> a
  counit (Pair_ish (rep, xs)) = xs `index` rep

to be able to derive, somehow

newtype Board a = Board_ (Compose V3 V3 a)
  deriving (Adjunction (Pair_ish Board))

instance Representable Board where
  type Rep Board = RowCol
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 23, 2017

Adjunction f g -> Compose f g is Monad, Pointed, Copointed, Comonad

from Control.Functor.Instances

newtype CompF f g a = CompF { deCompF :: f (g a) }
  deriving Functor

instance Adjunction f g => Applicative (CompF g f) where
  pure  = undefined 
  (<*>) = ap

instance Adjunction f g => Pointed (CompF g f) where
  point = CompF . unit

instance Adjunction f g => Copointed (CompF f g) where
  copoint = counit . deCompF

instance Adjunction f g => Monad (CompF g f) where
  return = point
  m >>= f = CompF . fmap (rightAdjunct (deCompF . f)) $ deCompF m

instance Adjunction f g => Comonad (CompF f g) where
  extract = copoint
  extend f = CompF . fmap (leftAdjunct (f . CompF)) . deCompF
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 23, 2017

https://hackage.haskell.org/package/adjunctions-4.3/docs/Control-Monad-Trans-Conts.html

Comonad w => MonadTrans (ContsT r w) 
Comonad w => Monad (ContsT r w m)   
Functor w => Functor (ContsT r w m)   
Comonad w => Applicative (ContsT r w m)   
Comonad w => Apply (ContsT r w m) 
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 25, 2017

As http://norvig.com/design-patterns/design-patterns.pdf discusses representing Rubik's cube as Cubies 3 3 3, Faces 6 3 3 or Faces 54 it is possible to represent these things as newtypes over a single thing.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 25, 2017

newtype V :: k -> Type -> Type where
  V :: Vector a -> V n a

where V n a is coercible to Vector a (TODO check: are you supposed to be able to coerce from Vector Int to V 666 Int?), but we can also create a newtype Faces n, Faces n m i and Cubies n m i that share the same representation.

This could be a cool example of representationally equal things, giving you very different perspectives on the item (derive different representations, now those start mattering since GHC 8.2 only lets you derive representationally equal things)


Definition something like

data Cubies :: Nat -> Nat -> Nat -> Type where
  Cubies :: (a * b * c) ~ n => V n Cubie -> Cubies a b c

-- .
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 25, 2017

Also stuff like the Functor, Applicative (how can we derive a Monad M instance?)

newtype M :: Nat -> Nat -> Type -> Type where
  M :: Compose (V n) (V m) a -> M n m a
  deriving newtype
    (Functor, Applicative, Trace)
  deriving via MonadJoin
    (Monad)

instance MonadJoin (M n m) where
  join_ = diagonal

and the almost-Category instance have the same representation

newtype M :: Type -> Cat Nat where
  M :: V n (V m a) -> M a n m 
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 25, 2017

Class per representation

newtype Pair a = Pair { getPair :: (a, a) }
  deriving Functor

class IsPair1 p where
  _Pair1 :: Iso (p a) (p a') (Pair a) (Pair a')
  _Pair1 = _Pair2 . _Pair1 
  default 
    _Pair1 :: IsPair2 p => Iso (p a) (p a') (Pair a) (Pair a')

class IsPair2 p where
  _Pair2 :: Iso (p a) (p a') (Bool -> a) (Bool -> a')
  _Pair2 = _Pair1 . _Pair2
  default 
    _Pair2 :: IsPair1 p => Iso (p a) (p a') (Bool -> a) (Bool -> a')

instance IsPair1 Pair where
  _Pair1 :: Iso (Pair a) (Pair a') (Pair a) (Pair a') 
  _Pair1 = id

instance IsPair2 Pair where
  _Pair2 :: Iso (Pair a) (Pair a') (Bool -> a) (Bool -> a')
  _Pair2 = iso
    (\(Pair (a, b)) -> bool a b)
    (\f -> Pair (f False, f True))

instance Coercible bool Bool => IsPair1 ((->) bool) where
  _Pair1 :: Iso (bool -> a) (bool -> a') (Pair a) (Pair a') 
  _Pair1 = iso
    (\f -> Pair (f (coerce False), f (coerce True)))
    (\(Pair (a, b)) -> \case
      (coerce -> False) -> a
      (coerce -> True)  -> b)

instance Coercible bool Bool => IsPair2 ((->) bool) where
  _Pair2 :: Iso (bool -> a) (bool -> a') (Bool -> a) (Bool -> a')
  _Pair2 = iso coerce coerce

mock associated pattern synonyms by providing

pattern (:#) :: IsPair1 p => a -> a -> p a
pattern a :# b <- (view _Pair1 -> Pair (a, b))
  where a :# b = review _Pair1   (Pair (a, b))

pattern Pair' :: IsPair2 p => (Bool -> a) -> p a
pattern Pair' f <- (view _Pair2 -> f)
  where Pair' f = review _Pair2    f

Each representation gives us a representation to round-trip to and fro, when defining Functor

newtype PAIR1 p a = PAIR1 (p a)
newtype PAIR2 p a = PAIR2 (p a)

instance IsPair1 p => Functor (PAIR1 p) where
  fmap :: (a -> a') -> (PAIR1 p a -> PAIR1 p a')
  fmap f (PAIR1 (a :# b)) = PAIR1 (f a :# f b)

instance IsPair2 p => Functor (PAIR2 p) where
  fmap :: (a -> a') -> (PAIR2 p a -> PAIR2 p a')
  fmap f (PAIR2 (Pair' k)) = PAIR2 (Pair' (k >>> f))

so we can keep track of two or more base-types, updating them when necessary:

data Foo a where
  Foo :: PAIR1 Pair        a
      -> PAIR2 ((->) Bool) a
      -> Foo a
  deriving 
    Functor
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 25, 2017

Then we can

newtype WrappedCoerce f a = WrapCoerce (f a)

instance Coercible pair Pair => IsPair1 (WrappedCoerce pair) where
  _Pair1 :: Iso (WrappedCoerce pair a) (WrappedCoerce pair a') (Pair a) (Pair a')
  _Pair1 = iso coerce coerce

instance Coercible f ((->) Bool) => IsPair2 (WrappedCoerce f) where
  _Pair2 :: Iso (WrappedCoerce f a) (WrappedCoerce f a') (Bool -> a) (Bool -> a')
  _Pair2 = iso coerce coerce
``
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 27, 2017

https://hackage.haskell.org/package/ad-4.3.3/docs/src/Numeric-AD-Mode.html#auto

Perfect for a newtype wrapper

instance Mode Double where 
  type Scalar Double = Double 
  isKnownConstant _ = True
  isKnownZero x = 0 == x 
  auto = id 
  (^/) = (/)

instance Mode Float where 
  type Scalar Float = Float
  isKnownConstant _ = True
  isKnownZero x = 0 == x 
  auto = id 
  (^/) = (/)
@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 28, 2017

https://www.reddit.com/r/haskell/comments/4ffd4j/adjunctions_bartosz_milewskis_programming_cafe/d2cjkay/

All Representable Functors are isomorphic to ((->) e) for some e, and their Adjunction is isomorphic to ((,) e)

we can show this with a newtype https://www.reddit.com/r/haskell/comments/6ox9ev/adjunctions_and_battleship/dklv8rt/

instance Representable r => Adjunction (Pair r) (Arr r) where
  unit :: a -> Arr r (Pair r a)
  unit a = Arr (tabulate (\b -> Pair (b, a)))

  counit :: Pair r (Arr r a) -> a
  counit (Pair (rep, xs)) = xs `index` rep
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Jul 29, 2017

also

class Num r => Coalgebra r m where
  comult :: (m -> r) -> m -> m -> r
  counital :: (m -> r) -> r

comultRep :: (Representable f, Coalgebra r (Rep f)) => f r -> f (f r)
comultRep fr = tabulate $ \i -> tabulate $ \j -> comult (index fr) i j

counitalRep :: (Representable f, Coalgebra r (Rep f)) => f r -> r
counitalRep = counital . index
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 1, 2017

IMPORTANT

The beautiful

convert :: (Representable r, Representable r', Rep r ~ Rep r') => r ~> r' 
convert = index > tabulate

convert @(Compose Pair Pair) @(Day Pair Pair) :: Compose Pair Pair ~> Day Pair Pair
convert @(Compose Pair Pair) @(Day Pair Pair) = index > tabulate

helps us jump between the composition of representable functors, and the

or as Kmett says

Day f ~ Compose f when f preserves colimits / is a left adjoint. (Due in part to the strength of all functors in Hask.)

Make a newtype wrapper that that uses the (Comonad f, Comonad g) => Comonad (Day f g) to derive Comonad (Compose f g), and ComonadApply

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 2, 2017

Num modifier to derive saturation arithmetic

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 2, 2017

https://github.com/ekmett/bound/blob/master/examples/Overkill.hs

instance Eq1 f => Eq1 (Pat b f) where liftEq = eqPat

but especially

instance Eq (Path i) where
    p == q = case compare p q of
               EQ -> True
               _  -> False
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 6, 2017

Important

From https://ghc.haskell.org/trac/ghc/ticket/10892#comment:4

Consider Data.Sequence. There

(<$>) is O(n), but (<$) is O(log n).

For any Functor that is representable, which is to say there exists x such that that f a is isomorphic to x -> a, you build a 'zipping' applicative that is isomorphic to reader. For that you can show that (m *> _ = m) and (_ <* m = m). So (<*) and (*>) are O(1) while the (<*>) pays for every point used. In the case of something like

data Stream a = a :- Stream a

which is isomorphic to Natural -> a, if we look at the zipping applicative (which behaves like ZipList) such an (*>) operation is O(1), but (<*>) incurs an ongoing cost O(n) in the length of the prefix of the result stream you inspect.

So this should get us those benefits without the user knowing anything about Representable functors

newtype Co' r a = Co' (r a) deriving newtype (Functor, Representable)
instance Representable r => Distributive (Co' r) where distribute = distributeRep

(!) = index

instance Representable r => Applicative (Co' r) where
  pure :: a -> Co' r a
  pure a = tabulate (\_ -> a)

  (<*>) :: Co' r (a -> b) -> (Co' r a -> Co' r b)
  f <*> g = tabulate ((f !) <*> (g !))

  (<*) :: Co' r a -> Co' r b -> Co' r a
  m <* _ = m

  (*>) :: Co' r a -> Co' r b -> Co' r b
  _ *> m = m

  liftA2 :: Representable f => (a -> b -> c) -> (f a -> f b -> f c)
  liftA2 (·) fa fb = tabulate (\i -> (fa!i) · (fb!i))
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 7, 2017

Yes absolutely @mrkgnao, this kind of custom deriving is exactly what I have been working on. I also see you are basing it off subhask and I like the different logics you pick through EquateResult, neat

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 9, 2017

I like calling them modifiers, but they are called

adapters

by The Essence of the Iterator Pattern:

We can capture this reversal quite elegantly as an applicative functor adapter:

newtype Backwards m a = Backwards{runBackwards :: m a}

...

Of course, there is a trivial forwards adapter too:

newtype Forwards m a = Forwards{runForwards :: m a}

also called wrappers (possible one, modifiers)

Alternative wrapper

From https://hackage.haskell.org/package/base-4.10.0.0/docs/src/Data.Monoid.html#Alt

Mentioned in comment

https://www.reddit.com/r/haskell/comments/31zagw/why_are_we_naming_types_instead_of_instances_when/cq7yez3/


Also from Understanding Idiomatic Traversals Backwards and Forwards

Yes, we can, by defining /treverse/ in terms of /traverse/ and a ‘backwards’ idiom. For each idiom M there is a corresponding idiom Backwards M with effects sequenced in the opposite order. This statement is not true when ‘idiom’ is replaced by ‘monad’, which is why we generalise from monads to idioms. We use the concepts and semantics from the Haskell library Control.Applicative.Backwards (the name forwards for the accessor is awkward but standard).

newtype Backwards m a = Backwards { fowards :: m a }

instance Applicative f => Applicative (Backwards f) where 
  pure x = Backwards (pure x)
  Backwards mf <*> Backwards mx = Backwards (pure (flip ($)) <*> mx <*> mf)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 10, 2017

todo

Can we do anything fun with things that are flipped, not representationally equal?

newtype WrapCat cat a b = WrapC (cat b a)

instance Category cat => Category (WrapCat cat) where
  id = WrapC id

  WrapC f . WrapC g = WrapC (g . f)

We can make use of the fact that they form an involution (is its own inverse).

The cool thing about this is that if we can keep track of this, maybe we can detect "this has been wrapped twice with WrapCat and thus the representation has not changed, so let's eliminate two runtime conversions... but wait I'm not even sure this makes sense

@Icelandjack

This comment has been minimized.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 15, 2017

class VectorSpace v where
  type Scalar v :: Type

  (*^) :: Scalar v -> v -> v

class HasBasis v where
  type Basis v :: Type

  basisValue   :: Basis v -> v

  decompose    :: v -> [(Basis v, Scalar v)]

  decompose'   :: v -> (Basis v -> Scalar v)

newtype WrappedHasBasis a = WrapHasBasis a
  deriving newtype
    Num

instance Num a => VectorSpace (WrappedHasBasis a) where
  type Scalar (WrappedHasBasis a) = a

  (*^) :: a -> WrappedHasBasis a -> WrappedHasBasis a
  (*^) a = coerce (a P.*)

instance Num a => HasBasis (WrappedHasBasis a) where 
  type Basis (WrappedHasBasis a) = ()

  basisValue :: () -> WrappedHasBasis a
  basisValue () = 1

  decompose :: WrappedHasBasis a -> [((), a)]
  decompose (WrapHasBasis a) = pure (pure a)

  decompose' :: WrappedHasBasis a -> (() -> a)
  decompose' (WrapHasBasis a) () = a

newtype USD = USD Int
  deriving newtype 
    Num

instance VectorSpace USD where
  type Scalar USD = Scalar (WrappedHasBasis Int)

  (*^) :: Scalar (WrappedHasBasis Int) -> USD -> USD
  (*^) = coerce ((*^) @(WrappedHasBasis Int))

instance HasBasis USD where
  type Basis USD = Basis (WrappedHasBasis Int)

  basisValue :: Basis (WrappedHasBasis Int) -> USD
  basisValue = coerce (basisValue @(WrappedHasBasis Int))

  decompose :: USD -> [(Basis (WrappedHasBasis Int), Scalar (WrappedHasBasis Int))]
  decompose = coerce (decompose @(WrappedHasBasis Int))

  decompose' :: USD -> (Basis (WrappedHasBasis Int) -> Scalar (WrappedHasBasis Int))
  decompose' = coerce (decompose' @(WrappedHasBasis Int))
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 15, 2017

newtype WrapMaybe f a = WrapMaybe (f a) 
  deriving newtype
    Functor

-- instance VectorSpace v => VectorSpace (Maybe v) where
--   type Scalar (Maybe v) = Scalar v
--   (*^) s = fmap (s *^)
--
-- instance (HasTrie a, VectorSpace v) => VectorSpace (a :->: v) where
--   type Scalar (a :->: v) = Scalar v
--   (*^) s = fmap (s *^)
instance (Functor f, VectorSpace a) => VectorSpace (WrapMaybe f a) where
  type Scalar (WrapMaybe f a) = Scalar a

  (*^) :: Scalar a -> WrapMaybe f a -> WrapMaybe f a
  (*^) s = fmap (s *^)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Aug 24, 2017

newtype WrappedIx f i j a = WrapIx (f i j a)
  deriving newtype
    Functor

instance (forall ii jj. Functor (f ii jj)) => IxFunctor (WrappedIx f) where
  imap f (WrapIx fija) = WrapIx (fmap f fija)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 7, 2017

Another use of WrappedApplicative

class Graph g where
  type Vertex g
  empty   :: g
  vertex  :: Vertex g -> g
  overlay :: g -> g -> g
  connect :: g -> g -> g

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

instance (Applicative f, Graph a) => Graph (WrappedApplicative f a) where
  type Vertex (WrappedApplicative f a) = Vertex a

  empty   = pure empty
  vertex  = pure . vertex
  overlay = liftA2 overlay
  connect = liftA2 connect

from which you can derive Graph g => Graph (a -> g) and Graph g => Graph (Maybe g).

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 9, 2017

newtype WrapDensity f g a = WrapDensity { getDensity :: f (g a) }
  deriving Functor

densityToComposedAdjoint :: forall f g a. 
  Adjunction f g => Density f a -> f (g a)
densityToComposedAdjoint = densityToLan > lanToComposedAdjoint

composedAdjointToDensity :: forall f g a. 
  Adjunction f g => f (g a) -> Density f a
composedAdjointToDensity = composedAdjointToLan > lanToDensity

instance (Apply f, Adjunction f g) => Apply (WrapDensity f g) where
  (<.>) :: forall a b. WrapDensity f g (a -> b) -> WrapDensity f g a -> WrapDensity f g b
  WrapDensity ff <.> WrapDensity xx = WrapDensity $ let

    f :: Density f (a -> b)
    f = composedAdjointToDensity ff

    x :: Density f a
    x = composedAdjointToDensity xx

    in 
      densityToComposedAdjoint (f B.<.> x)
        
instance Adjunction f g => Comonad (WrapDensity f g) where
  extract :: WrapDensity f g a -> a
  extract = getDensity > composedAdjointToDensity > extract

  duplicate :: forall a. WrapDensity f g a -> WrapDensity f g (WrapDensity f g a)
  duplicate (WrapDensity fga) = let
    x :: Density f (Density f a)
    x = duplicate (composedAdjointToDensity fga)

    y :: WrapDensity f g (WrapDensity f g a)
    y = WrapDensity $ densityToComposedAdjoint (fmap (WrapDensity . densityToComposedAdjoint) x)

    in 
      y
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 13, 2017

data FailOver = FailOver { foNearestN :: Maybe Integer, foDatacenters :: [Text] }
  deriving (Generic, Show)
defFailover :: FailOver
defFailover = FailOver Nothing []
jsonFailOver :: A.Options
jsonFailOver = A.defaultOptions { A.fieldLabelModifier = drop (T.length "fo"), A.omitNothingFields = True }
instance A.FromJSON FailOver where
  parseJSON = A.genericParseJSON jsonFailOver
instance A.ToJSON FailOver where
  toJSON = A.genericToJSON jsonFailOver

also

TODO

we can mechanically get rid of default methods by translating each of them into a newtype with the required constraints.

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 14, 2017

https://www.schoolofhaskell.com/user/griba/safe_int_addition_and_product

intAddEx :: (Eq a, Num a) => a -> a -> a
intAddEx x y  
  | signum x == signum y =
             if signum result == signum x
               then result
               else throw Overflow
  | otherwise = result -- no risk of overflow when sign differs
  where result = x + y

intAddMay :: (Eq a, Num a) => a -> a -> Maybe a
intAddMay x y
  | signum x == signum y =
             if signum result == signum x
               then Just result
               else Nothing
  | otherwise = Just result -- no risk of overflow when sign differs
  where result = x + y

#define BLOC( IntEN, IntN) \
newtype IntEN = IntEN IntN deriving (Show, Eq, Ord, Enum, Bounded, Real, Integral) ; \
instance Num IntEN where {\
    IntEN x + IntEN y = IntEN (intAddEx x y) ; \
    IntEN x * IntEN y = IntEN (intProdEx x y) ; \
    abs (IntEN x) = IntEN (abs x) ; \
    signum (IntEN x) = IntEN (signum x) ; \
    fromInteger = IntEN . fromInteger ; \
    negate (IntEN x) = IntEN (negate x) ; \
         }

BLOC( IntE, Int)
BLOC( IntE8, Int8)
BLOC( IntE16, Int16)
BLOC( IntE32, Int32)
BLOC( IntE64, Int64)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 14, 2017

https://arxiv.org/pdf/1708.09158.pdf

We can derive IMonad Edis from Monad Redis

newtype Edis p q a = Edis { unEdis :: Redis a }

instance IMonad Edis where
  unit = Edis · return
  bind m f = Edis (unEdis m >>= unEdis . f)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 16, 2017

https://ghc.haskell.org/trac/ghc/ticket/13403#comment:5

-- Applicative
genericPure :: (Generic1 f, Applicative (Rep1 f)) => a -> f a
genericPure = to1 . pure

genericAp :: (Generic1 f, Applicative (Rep1 f)) => f (a -> b) -> f a -> f b
genericAp f x = to1 $ from1 f <*> from1 x

-- Monad
genericBind :: (Generic1 m, Monad (Rep1 m)) => m a -> (a -> m b) -> m b
genericBind m f = to1 $ from1 m >>= from1 . f

newtype WrappedGeneric f a = WrapGeneric (f a)

instance (Generic1 f, Applicative (Rep1 f)) => Functor (WrappedGeneric f) where
  fmap = liftA

instance (Generic1 f, Applicative (Rep1 f)) => Applicative (WrappedGeneric f) where
  pure = WrapGeneric . genericPure
  WrapGeneric f <*> WrapGeneric x = WrapGeneric (genericAp f x)

instance (Generic1 f, Monad (Rep1 f)) => Monad (WrappedGeneric f) where
  WrapGeneric f >>= k = WrapGeneric b where
    b = genericBind f (\(k -> WrapGeneric b) -> b)

data Product f g h a = Product (f (g (f a))) (h (f (g a)))
  deriving 
    (Functor, Generic1)
  deriving via WrappedGeneric
    (Applicative, Monad, Foldable1, ...)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 16, 2017

TODO

Need to go the other way,

data ONE a = ONE a a a deriving (Show, Generic1)
data TWO a = TWO a a a deriving (Show, Generic1)

we can convert from one to the other

to1 (coerce (from1 (ONE 1 2 3))) :: TWO Int

So

instance A ONE
instance B TWO

means

data THR a = THR a a a 
  deriving 
    (Show, Generic1)

  deriving via (G ONE)
    A

  deriving via (G TWO)
    B

with some

newtype G f' f a = G (f a)

instance (Generic f, Generic f', (forall xx. Coercible (Rep1 f xx) (Rep1 f' xx))) => A (G f' f)

instance (Generic f, Generic f', (forall xx. Coercible (Rep1 f xx) (Rep1 f' xx))) => B (G f' f)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 16, 2017

Find a way to derive

data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
                    | GivenTheta (DerivSpec ThetaType)

earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec) = ds_loc spec
earlyDSLoc (GivenTheta spec) = ds_loc spec

splitEarlyDerivSpec :: [EarlyDerivSpec]
                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
splitEarlyDerivSpec (GivenTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)

from Either

newtype EarlyDerivSpec = EDS (DerivSpec [ThetaOrigin] `Either` DerivSpec ThetaType)
  deriving newtype
    ( splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
      splitEarlyDerivSpec = partitionEithers

    , earlyDSLoc :: EarlyDerivSpec -> SrcSpan
      earlyDSLoc = either ds_loc ds_loc
    )
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 17, 2017

This would allow us to write

newtype Maybe a = K (Either () a)
  deriving newtype
    Show

  deriving newtype
    ( maybe :: (() -> r) -> (a -> r) -> (Maybe a -> r)
      maybe = either
    
    , catMaybes :: [Maybe a] -> [a]
      catMaybes = rights

    , fromMaybe :: a -> Maybe a -> a
      fromMaybe = fromRight

    , isJust :: Maybe a -> Bool
      isJust = isRight

    , isNothing :: Maybe a -> Bool
      isNothing = isLeft
    )

pattern Nothing = K (Left ())
pattern Just a = K (Right a)
newtype Bool = B (Maybe ())
  deriving newtype
    ( bool :: (() -> r) -> (() -> r) -> (Bool -> r)
      bool = maybe

    , not :: Bool -> Bool
      not = isNothing
    )
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 17, 2017

almost

data HsAppType pass
  = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks
  | HsAppPrefix (LHsType pass)      -- anything else, including things like (+)

splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)])
splitHsAppsTy = go [] [] []
  where
    go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
    go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
      = go (ty : acc) acc_non acc_sym rest
    go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
      = go [] (reverse acc : acc_non) (op : acc_sym) rest
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 19, 2017

https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-TH.html#v:makeClassy

class HasFoo t where
  foo :: Lens' t Foo
  fooX :: Lens' t Int
  fooX = foo . go where go f (Foo x y) = (\x' -> Foo x' y) <$> f x
  fooY :: Lens' t Int
  fooY = foo . go where go f (Foo x y) = (\y' -> Foo x y') <$> f y

instance HasFoo Foo where
  foo = id
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 19, 2017

Derive Foldable from fold

newtype WrapFold f a = WrappedFold (f a)
  deriving newtype
    (Functor, Fold_)

class Functor f => Fold_ f where
  fold_ :: Monoid m => f m -> m

instance Fold_ f => Foldable (WrapFold f) where
  fold    = fold_
  foldMap f (fmap f -> fm) = fold_ fm
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 20, 2017

newtype that allows you to generate Arbitrary with special "edge cases"

nick8325/quickcheck#98

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

Conor McBride gets it as usual, https://www.youtube.com/watch?v=3U3lV5VPmOU example for newtype is deriving Alternative structure from Monoids

import Data.Constraint.Forall -- so people can find this with Google, hey!

newtype W f a = W (f a) deriving newtype (Functor, Applicative, Monoid)

instance (Applicative f, ForallF Monoid f) => Alternative (W f) where
  empty :: forall a. W f a
  empty = mempty \\ instF @Monoid @f @a

  (<|>) :: forall a. W f a -> W f a -> W f a
  (<|>) = mappend \\ instF @Monoid @f @a
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

representationally equal, very different structures

newtype P0 a = P0 (String -> [(a, String)])
newtype P1 a = P1 (Kleisli [] String (a, String))
newtype P2 a = P2 (StateT String [] a)
newtype P3 a = P3 (String -> Tannen [] (,) a String) 
newtype Q0 a = Q0 (String -> [(String, a)]) 
newtype Q1 a = Q1 (Kleisli (Compose [] ((,) String)) String a) 
newtype Q2 a b = Q2 (Kleisli (Compose [] ((,) String)) a b) 
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

Arrow cat implies Applicative (cat a)

From http://strictlypositive.org/Idiom.pdf

newtype FixArrow cat a b = Fix (cat a b)

instance Arrow cat => Applicative (FixArrow cat a) where
  pure a = Fix (arr (pure a))

  Fix u <*> Fix v = Fix ((u **** v) >>> arr (\(f, x) -> f x)) where
    u****v = arr dup >>> first u >>> arr swap >>> first u >>> arr swap
    dup a = (a, a)

Arrow from Applicative and existing Arrow

newtype Tannen f p a b = Tannen (f (p a b))

instance (Applicative f, Arrow p) => Arrow (Tannen f p) where
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

http://strictlypositive.org/Idiom.pdf

We can derive this from Maybe (Max a) in the next GHC release when Semigroup a => Monoid (Maybe a)

newtype Pointed a = P_ (Maybe a)
  deriving newtype
    (Show, Eq)

pattern Bottom     = P_ Nothing
pattern Embedded x = P_ (Just x)

instance Ord a => Ord (Pointed a) where
  Bottom     `compare` Bottom     = EQ
  Bottom     `compare` Embedded _ = LT
  Embedded _ `compare` Bottom     = GT
  Embedded a `compare` Embedded b = a `compare` b

instance Ord a => Monoid (Pointed a) where
  mempty  = Bottom
  mappend = max
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

{-# Language DependentTypes #-}

newtype WithMonoid (mempty' :: a) (mappend' :: a -> a -> a) a where
  WithMonoid :: a -> WithMonoid mempty' mappend' a

instance Semigroup (WithMonoid mempty' mappend') where
  WithMonoid a <> WithMonoid b = WithMonoid (mappend' a b)

instance Monoid (WithMonoid mempty' mappend') where
  mempty = WithMonoid mempty'

https://personal.cis.strath.ac.uk/conor.mcbride/so-pigworker.pdf

newtype Merge a = Merge [a]
  deriving via (WithMonoid '[] 'merge [a])
    (Semigroup, Monoid)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 22, 2017

https://personal.cis.strath.ac.uk/conor.mcbride/so-pigworker.pdf

newtype ArrayLike a = MkAL 
  (Product
    (Compose Maybe Min)
    ((->) Int)
    a)
  deriving newtype
    (Functor, Applicative, Monad)

instance Swap Min Maybe where
  swap :: Min (Maybe a) -> Maybe (Min a)
  swap = coerce
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 23, 2017

https://stackoverflow.com/questions/32935812/why-isnt-kleisli-an-instance-of-monoid

type (·) = WrappedApplicative
newtype KLEISLI m a b = KLEISLI (a -> m b)

instance (Applicative f, Semigroup b) => Semigroup (KLEISLI f a b) where
  (<>) = coerce ((<>) @(a -> f·b))

instance (Applicative f, Monoid b) => Monoid (KLEISLI f a b) where
  mempty = coerce (mempty @(a -> f·b))

newtype KLEISLI' (m :: Type -> Type) a b = KLEISLI' (a -> m·b)
  deriving newtype
    (Semigroup, Monoid)

newtype KLEISLI'' (m :: Type -> Type) a b = KLEISLI'' ((->) a·(m·b))
  deriving newtype
    (Num, Fractional, Floating)

so we can eventually write

newtype KLEISLI m a b = KLEISLI (a -> m b)
  deriving via (a -> m·b)
    (Semigroup, Monoid)

  deriving via ((a ->)·(m·b))
    (Num, Fractional, Floating, ...)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 23, 2017

newtype Alt_ f a = Alt_ (f a)
  deriving newtype
    (Functor, Applicative, Alternative)

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

which could derive for ListT in Pipes, confusingly Alt from Control.Alternative.Free... this existed in Kmett's reducer's package

-- | A 'Alternate' turns any 'Alternative' instance into a 'Monoid'.

newtype Alternate f a = Alternate { getAlternate :: f a }
  deriving (Functor,Applicative,Alternative)

instance Alternative f => Semigroup (Alternate f a) where
  Alternate a <> Alternate b = Alternate (a <|> b)

instance Alternative f => Monoid (Alternate f a) where
  mempty = empty
  Alternate a `mappend` Alternate b = Alternate (a <|> b)

Alternative wrapper

and in https://hackage.haskell.org/package/base-4.10.0.0/docs/src/Data.Monoid.html#Alt

newtype Alt f a = Alt {getAlt :: f a}
  deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,
            Monad, MonadPlus, Applicative, Alternative, Functor)

-- | @since 4.8.0.0
instance Alternative f => Monoid (Alt f a) where
        mempty = Alt empty
        mappend = coerce ((<|>) :: f a -> f a -> f a)

also

instance Monoid (SmallArray a) where
  mempty = empty
  mappend = (<|>)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 24, 2017

newtype Fold1Fold f g a = F1F (P.Product f g a)                                                                                                                                 
  deriving stock                                                                                                                                                                
    Foldable                                                                                                                                                                    
                                                                                                                                                                                
newtype FoldFold1 f g a = FF1 (P.Product f g a)                                                                                                                                 
  deriving stock                                                                                                                                                                
    Foldable                                                                                                                                                                    
                                                                                                                                                                                
instance (Foldable1 f, Foldable g) => Foldable1 (Fold1Fold f g) where                                                                                                           
  foldMap1                                                                                                                                                                      
    :: forall a s. Semigroup s                                                                                                                                                  
    => (a               -> s)                                                                                                                                                   
    -> (Fold1Fold f g a -> s)                                                                                                                                                   
  foldMap1 f (F1F (P.Pair fa ga)) =                                                                                                                                             
    case foldMap (Option . Just . f) ga of                                                                                                                                      
      Option Nothing  -> foldMap1 f fa                                                                                                                                          
      Option (Just s) -> foldMap1 f fa <> s                                                                                                                                     
                                                                                                                                                                                
instance (Foldable f, Foldable1 g) => Foldable1 (FoldFold1 f g) where                                                                                                           
  foldMap1                                                                                                                                                                      
    :: forall a s. Semigroup s                                                                                                                                                  
    => (a               -> s)                                                                                                                                                   
    -> (FoldFold1 f g a -> s)                                                                                                                                                   
  foldMap1 f (FF1 (P.Pair fa ga)) =                                                                                                                                             
    case foldMap (Option . Just . f) fa of                                                                                                                                      
      Option Nothing  ->      foldMap1 f ga                                                                                                                                     
      Option (Just s) -> s <> foldMap1 f ga                                                                                                                                     
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 25, 2017

Goldmine from Kmett: https://github.com/ekmett/reducers/tree/master/src/Data/Semigroup

newtype Alter f a = Alter { getAlter :: f a }
    deriving (Functor,Plus)

instance Alt f => Alt (Alter f) where
    Alter a <!> Alter b = Alter (a <!> b)

instance Alt f => Semigroup (Alter f a) where
    Alter a <> Alter b = Alter (a <!> b)

instance Plus f => Monoid (Alter f a) where
    mempty = zero
    Alter a `mappend` Alter b = Alter (a <!> b)

where Semigroup (Alter f a) could actually be derived with another adapter (and Alt (Alter f) could be newtype derived).

Also

newtype Trav f = Trav { getTrav :: f () }

instance Apply f => Semigroup (Trav f) where
  Trav a <> Trav b = Trav (a .> b)
newtype Traversal f = Traversal { getTraversal :: f () }

instance Applicative f => Semigroup (Traversal f) where
  Traversal a <> Traversal b = Traversal (a *> b)

instance Applicative f => Monoid (Traversal f) where
  mempty = Traversal (pure ())
  Traversal a `mappend` Traversal b = Traversal (a *> b)

used in On the Duality of Streams

type Eff = IO ()

instance Monoid Eff where
  mempty = pure ()
  (<>) = (>>)

TODO

This can be used for cerial

instance Monoid (PutM ()) where
    mempty = pure ()
    mappend = (*>)
newtype UnionWith f m = UnionWith { getUnionWith :: f m }

instance (HasUnionWith f, Semigroup m) => Semigroup (UnionWith f m) where
    UnionWith a <> UnionWith b = UnionWith (unionWith (<>) a b)

instance (HasUnionWith0 f, Monoid m) => Monoid (UnionWith f m) where
    mempty = UnionWith emptyWith
    UnionWith a `mappend` UnionWith b = UnionWith (unionWith mappend a b)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 25, 2017

Very nice, no {,un}wrapping because we can derive MonadTrans: perfect.

newtype F monT m a = F (monT m a)
  deriving newtype
    (Functor, Applicative, Monad, MonadTrans)

instance (MonadState s m, MonadTrans monT, Monad (monT m)) => MonadState s (F monT m) where
  get :: F monT m s
  get = lift get

  put :: s -> F monT m ()
  put = lift . put

  state :: (s -> (a, s)) -> F monT m a
  state = lift . state

How do derive MonadState?

newtype KannskiT m a = KannskiT { runKannskiT :: m (Maybe a) }
  deriving stock
    Functor

instance Monad m => Applicative (KannskiT m) where
  pure = lift . return

  mf <*> mx = KannskiT $ do
    mb_f <- runKannskiT mf
    case mb_f of
      Nothing -> return Nothing
      Just f  -> do
        mb_x <- runKannskiT mx
        case mb_x of
          Nothing -> return Nothing
          Just x  -> return (Just (f x))

instance Monad m => Monad (KannskiT m) where
  x >>= f = KannskiT $ do
    v <- runKannskiT x
    case v of
      Nothing -> return Nothing
      Just y  -> runKannskiT (f y)

instance MonadTrans KannskiT where
  lift :: Monad m => m ~> KannskiT m
  lift ma = KannskiT (Just <$> ma)

instance MonadState e m => MonadState e (KannskiT m) where
  get :: KannskiT m e
  get = coerce (get @e @(F KannskiT m))

  put :: e -> KannskiT m ()
  put = coerce (put @e @(F KannskiT m))

  state :: forall a. (e -> (a, e)) -> KannskiT m a
  state = coerce (state @e @(F KannskiT m) @a)
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 28, 2017

instance Monoid Void

newtype Not a = Not (Op Void a)
  deriving
    (Contravariant, Divisible, Decidable)

-- cursory glance: it's the First monoid
newtype Cx b a = Cx { unCx :: Op (First b) a }
  deriving
    (Contravariant, Divisible, Decidable)

from http://www.michaelburge.us/2017/09/27/delta-debugging-in-haskell.html

@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Sep 30, 2017

https://github.com/Icelandjack/deriving-via/blob/master/examples/CoerceTypeFamily.hs

newtype W :: Type -> (Type -> Type) -> (Type -> Type) where
  W :: { unW :: f a } -> W rep f a
  deriving newtype
    Functor

instance Distributive d => Distributive (W rep d) where
  distribute :: Functor f => f (W rep d a) -> W rep d (f a)
  distribute = W . distribute . fmap unW

instance (Representable f, rep `Coercible` Rep f) => Representable (W rep f) where
  type Rep (W rep f) = rep

  index :: forall a. W rep f a -> rep -> a
  index = coerce (index @f @a)

  tabulate :: forall a. (rep -> a) -> W rep f a
  tabulate = coerce (tabulate @f @a)

newtype PairIx = PairIx (Either () ())

instance Show PairIx where
  show = \case
    Fst -> "fst"
    Snd -> "snd"

pattern Fst, Snd :: PairIx
pattern Fst = PairIx (Left  ())
pattern Snd = PairIx (Right ())

newtype Pair a = Pair (Product Identity Identity a)
  deriving newtype
    Functor

instance Distributive Pair where
  distribute = distributeRep

instance Representable Pair where
  type Rep Pair = PairIx

  index :: forall a. Pair a -> PairIx -> a
  index = coerce (index @(W PairIx Pair) @a)

  tabulate :: forall a. (PairIx -> a) -> Pair a
  tabulate = coerce (tabulate @(W PairIx Pair) @a)

This lets us derive Representable for newtype Pair a = Pair_ (Product Identity Identity a)

This normally gives us Rep Pair = Either () () but that is not a pretty representation.

One way to derive PairIx directly is using PairIx -> a but we have to change representations

This shows how to derive it for a coercible type: PairIx the user can specify

Here the user can write

newtype Pair a = Pair_ (Product Identity Identity a)
  deriving 
    (..., Representable)
    via 
      Wrap PairIx (Product Identity Identity) a
@Icelandjack

This comment has been minimized.

Copy link
Owner Author

@Icelandjack Icelandjack commented Oct 4, 2017