Instantly share code, notes, and snippets.

Embed
What would you like to do?
Alternate definition of FApplicative aka FMonoidal
{-# 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}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment