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 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)