Newtype wrappers for deriving

newtype_wrappers.markdown

Getting Num, Floating, Fractional from Applicative

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

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

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

instance (Applicative f, Floating a) => Floating (WrappedApplicative 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 (WrappedApplicative f s) where
  (<>) = liftA2 (<>)

instance (Applicative f, Monoid m) => Monoid (WrappedApplicative f m) where
  mempty  = pure mempty
  mappend = liftA2 mappend

Getting Applicative from Monad

newtype WrappedMonad m a = WrapMonad (m a)
  deriving newtype 
    Monad

instance Monad m => Functor (WrappedMonad m) where
  fmap f (WrapMonad v) = WrapMonad (liftM f v)

instance Monad m => Applicative (WrappedMonad m) where
  pure = WrapMonad . return
  WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)

Getting Arbitrary, CoArbitrary from Enum, Bounded

newtype WrappedArbitraryEnum a = WrapArbitraryEnum a
  deriving 
    (Enum, Bounded)

instance (Enum a, Bounded a) => Arbitrary (WrappedArbitraryEnum a) where
  arbitrary :: Gen (WrappedArbitraryEnum a)
  arbitrary = arbitraryBoundedEnum

instance Enum a => CoArbitrary (WrappedArbitraryEnum a) where
  coarbitrary :: WrappedArbitraryEnum a -> Gen b -> Gen b
  coarbitrary = coarbitraryEnum

Getting Arbitrary, CoArbitrary from Integral, Bounded

newtype WrappedArbitraryIntegral a = WrapArbitraryIntegral a
  deriving 
    (Ord, Eq, Enum, Bounded)
  deriving newtype 
    (Num, Real, Integral)

instance (Integral a, Bounded a) => Arbitrary (WrappedArbitraryIntegral a) where
  arbitrary :: Gen (WrappedArbitraryIntegral a)
  arbitrary = arbitraryBoundedIntegral

instance Integral a => CoArbitrary (WrappedArbitraryIntegral a) where
  coarbitrary :: WrappedArbitraryIntegral a -> Gen b -> Gen b
  coarbitrary = coarbitraryIntegral

Getting Arbitrary from Random, Bounded

newtype WrappedArbitraryRandom a = WrapArbitraryRandom a
  deriving newtype
    (Bounded, Random)

instance (Random a, Bounded a) => Arbitrary (WrappedArbitraryRandom a) where
  arbitrary :: Gen (WrappedArbitraryRandom a)
  arbitrary = arbitraryBoundedRandom

Getting Bifunctor, Bifoldable from Bitraversable

newtype WrappedBif f a b = WrapBif (f a b)

instance Bitraversable t => Bifunctor (WrappedBif t) where
  bimap :: (a -> a') -> (b -> b') -> (WrappedBif t a b -> WrappedBif t a' b')
  bimap = bimapDefault

instance Bitraversable t => Bifoldable (WrappedBif t) where
  bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> (WrappedBif t a b -> m)
  bifoldMap = bifoldMapDefault

instance Bitraversable t => Bitraversable (WrappedBif t) where
  bitraverse :: Applicative f
             => (a -> f a') 
             -> (b -> f b') 
             -> (WrappedBif t a b -> f (WrappedBif t a' b'))
  bitraverse f g (WrapBif fab) = WrapBif <$> bitraverse f g fab

Getting (>>=) from join and fmap

class Functor m => MonadJoin m where
  return_  :: a -> m a
  join_    :: m (m a) -> m a

newtype WrappedMonadJoin m a = WrapMonadJoin { unwrapMonadJoin :: m a }
  deriving newtype (Functor, Applicative)

instance MonadJoin m => MonadJoin (WrappedMonadJoin m) where
  return_ a = WrapMonadJoin (return_ a)

  join_ (WrapMonadJoin mma) = WrapMonadJoin $ join_ (fmap unwrapMonadJoin mma)

instance (Applicative m, MonadJoin m) => Monad (WrappedMonadJoin m) where
  return   = return_
  ma >>= k = join_ (fmap k ma)

Getting pure, (<*>) from unit, (**)

class Functor f => Monoidal f where
  unit :: f ()
  (**) :: f a -> f b -> f (a,b)

newtype WrappedMonoidal f a = WrapMonoidal (f a)
  deriving newtype
    (Functor, Monoidal)

instance Monoidal f => Applicative (WrappedMonoidal f) where
  pure :: a -> WrappdMonoidal f a
  pure a = a <$ unit 

  (<*>) :: WrappedMonoidal f (a -> b) -> WrappedMonoidal f a -> WrappedMonoidal f b
  mf <*> mx = fmap (uncurry id) (mf ** mx)