Alternate definition of FApplicative aka FMonoidal

FFunctor.hs

{-# OPTIONS_GHC -Wall -Werror -Wextra #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module FFunctor where
import Unsafe.Coerce (unsafeCoerce)
import Data.Functor.Identity (Identity(..))
import Data.Functor.Const (Const(..))

type (~>) (a :: k -> *) (b :: k -> *) = forall (x :: k) . a x -> b x

class FFunctor (f :: (k -> *) -> *) where
  ffmap :: (a ~> b) -> f a -> f b

(<$|) :: FFunctor f => (a ~> b) -> f a -> f b
(<$|) = ffmap
infixr 4 <$|

class FFunctor f => FMonoidal (f :: (k -> *) -> *) where
   unit :: f (Seq '[])
   (|*|) :: f a -> f (Seq as) -> f (Seq (a ': as))
infixr 4 |*|

pure :: FMonoidal f => (forall x. a x) -> f a
pure a_ = runSeq a_ <$| unit

(|*>) :: FMonoidal f => f a -> f b -> f (Seq '[a,b])
(|*>) fa fb = fa |*| fb |*| unit
infixr 4 |*>

(<*|) :: (FFunctor f, RunSeq as) => (forall x. Fun as r x) -> f (Seq as) -> f r
(<*|) h fas = runSeq (unsafeCoerce h) <$| fas
infixr 4 <*|

fliftA2 :: FMonoidal f => (forall x. a x -> b x -> c x) -> f a -> f b -> f c
fliftA2 g fa fb = g <*| fa |*> fb

fliftA3 :: FMonoidal f => (forall x. a x -> b x -> c x -> d x) -> f a -> f b -> f c -> f d
fliftA3 g fa fb fc = g <*| fa |*| fb |*> fc

data Seq (as :: [k -> *]) (x :: k) where
  End :: Seq '[] x
  (:>) :: a x -> Seq as x -> Seq (a ': as) x
infixr 5 :>

class RunSeq (as :: [k -> *]) where
  type Fun as (r :: k -> *) (x :: k) :: *
  runSeq :: Fun as r x -> Seq as x -> r x

instance RunSeq '[] where
  type Fun '[] r x = r x
  runSeq r_ End = r_

instance RunSeq as => RunSeq (a ': as) where
  type Fun (a ': as) r x = a x -> Fun as r x
  runSeq f (ax :> asx) = runSeq (f ax) asx

--------------------------------------------------------------------------------

data ExampleF (a :: * -> *) = ExampleF
  { _primary :: a String
  , _secondary :: a String
  , _tertiary :: a Int
  , _final :: a Int
  }

deriving instance (Show (a String), Show (a Int)) => Show (ExampleF a)
deriving instance (Eq (a String), Eq (a Int)) => Eq (ExampleF a)

instance FFunctor ExampleF where
  ffmap h (ExampleF {..}) = ExampleF (h _primary) (h _secondary) (h _tertiary) (h _final)

instance FMonoidal ExampleF where
  unit = ExampleF End End End End
  ExampleF w x y z |*| ExampleF ws xs ys zs = ExampleF (w :> ws) (x :> xs) (y :> ys) (z :> zs)

ex0 :: ExampleF (Const Bool)
ex0 = ExampleF (Const True) (Const False) (Const True) (Const False)

ex1, ex2 :: ExampleF Identity
ex1 = ExampleF (Identity "hello") (Identity "goodbye") (Identity 0) (Identity 1)
ex2 = ExampleF (Identity "thanks") (Identity "welcome") (Identity 10) (Identity 20)

ifThenElse :: Bool -> a -> a -> a
ifThenElse b = if b then const else flip const

-- $ 
-- >>> ifThenElse . getConst <*| ex0 |*| ex1 |*> ex2
-- ExampleF {_primary = Identity "hello", _secondary = Identity "welcome", _tertiary = Identity 0, _final = Identity 20}