-- | -- Module : Data.Functor.Apply.Free -- Copyright : (c) Justin Le 2019 -- License : BSD3 -- -- Maintainer : justin@jle.im -- Stability : experimental -- Portability : non-portable -- -- The free 'Apply'. Provides 'Ap1' and various utility methods. See -- 'Ap1' for more details. -- -- Ideally 'Ap1' would be in the /free/ package. However, it is defined -- here for now. module Data.Functor.Apply.Free ( Ap1(.., DayAp1, ap1Day) , toAp, fromAp , liftAp1 , retractAp1 , runAp1 ) where import Control.Applicative.Free import Control.Natural import Data.Function import Data.Functor.Apply import Data.Functor.Day import Data.Functor.Identity import Data.Functor.Invariant import Data.HFunctor import Data.HFunctor.HTraversable import Data.HFunctor.Interpret import Data.Kind import GHC.Generics -- | One or more @f@s convolved with itself. -- -- Essentially: -- -- @ -- 'Ap1' f -- ~ f -- one f -- ':+:' (f \`'Day'` f) -- two f's -- :+: (f \`Day\` f \`Day\` f) -- three f's -- :+: (f \`Day\` f \`Day\` f \`Day\` f) -- four f's -- :+: ... -- etc. -- @ -- -- Useful if you want to promote an @f@ to a situation with "at least one -- @f@ sequenced with itself". -- -- Mostly useful for its 'HFunctor' and 'Interpret' instance, along with -- its relationship with 'Ap' and 'Day'. -- -- This is the free 'Apply' --- Basically a "non-empty" 'Ap'. -- -- The construction here is based on 'Ap', similar to now -- 'Data.List.NonEmpty.NonEmpty' is built on list. data Ap1 :: (Type -> Type) -> Type -> Type where Ap1 :: f a -> Ap f (a -> b) -> Ap1 f b -- | An 'Ap1' is a "non-empty" 'Ap'; this function "forgets" the non-empty -- property and turns it back into a normal 'Ap'. toAp :: Ap1 f ~> Ap f toAp :: Ap1 f x -> Ap f x toAp (Ap1 f a x Ap f (a -> x) xs) = f a -> Ap f (a -> x) -> Ap f x forall (f :: * -> *) a1 a. f a1 -> Ap f (a1 -> a) -> Ap f a Ap f a x Ap f (a -> x) xs -- | Convert an 'Ap' into an 'Ap1' if possible. If the 'Ap' was "empty", -- return the 'Pure' value instead. fromAp :: Ap f ~> (Identity :+: Ap1 f) fromAp :: Ap f x -> (:+:) Identity (Ap1 f) x fromAp = \case Pure x x -> Identity x -> (:+:) Identity (Ap1 f) x forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p L1 (Identity x -> (:+:) Identity (Ap1 f) x) -> Identity x -> (:+:) Identity (Ap1 f) x forall a b. (a -> b) -> a -> b $ x -> Identity x forall a. a -> Identity a Identity x x Ap f a1 x Ap f (a1 -> x) xs -> Ap1 f x -> (:+:) Identity (Ap1 f) x forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p R1 (Ap1 f x -> (:+:) Identity (Ap1 f) x) -> Ap1 f x -> (:+:) Identity (Ap1 f) x forall a b. (a -> b) -> a -> b $ f a1 -> Ap f (a1 -> x) -> Ap1 f x forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 f a1 x Ap f (a1 -> x) xs -- | @since 0.3.0.0 instance Invariant (Ap1 f) where invmap :: (a -> b) -> (b -> a) -> Ap1 f a -> Ap1 f b invmap a -> b f b -> a _ = (a -> b) -> Ap1 f a -> Ap1 f b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> b f -- | An @'Ap1' f@ is just a @'Day' f ('Ap' f)@. This bidirectional pattern -- synonym lets you treat it as such. pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a pattern $bDayAp1 :: Day f (Ap f) a -> Ap1 f a $mDayAp1 :: forall r (f :: * -> *) a. Ap1 f a -> (Day f (Ap f) a -> r) -> (Void# -> r) -> r DayAp1 { Ap1 f a -> Day f (Ap f) a ap1Day } <- ((\case Ap1 x y -> Day x y (&)) -> ap1Day) where DayAp1 (Day f b x Ap f c y b -> c -> a f) = f b -> Ap f (b -> a) -> Ap1 f a forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 f b x ((b -> c -> a) -> c -> b -> a forall a b c. (a -> b -> c) -> b -> a -> c flip b -> c -> a f (c -> b -> a) -> Ap f c -> Ap f (b -> a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Ap f c y) {-# COMPLETE DayAp1 #-} deriving instance Functor (Ap1 f) instance Apply (Ap1 f) where Ap1 f a x Ap f (a -> a -> b) xs <.> :: Ap1 f (a -> b) -> Ap1 f a -> Ap1 f b <.> Ap1 f a ys = f a -> Ap f (a -> b) -> Ap1 f b forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 f a x ((a -> a -> b) -> a -> a -> b forall a b c. (a -> b -> c) -> b -> a -> c flip ((a -> a -> b) -> a -> a -> b) -> Ap f (a -> a -> b) -> Ap f (a -> a -> b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Ap f (a -> a -> b) xs Ap f (a -> a -> b) -> Ap f a -> Ap f (a -> b) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Ap1 f a -> Ap f a forall (f :: * -> *). Ap1 f ~> Ap f toAp Ap1 f a ys) -- | Embed an @f@ into 'Ap1'. liftAp1 :: f ~> Ap1 f liftAp1 :: f x -> Ap1 f x liftAp1 f x x = f x -> Ap f (x -> x) -> Ap1 f x forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 f x x ((x -> x) -> Ap f (x -> x) forall a (f :: * -> *). a -> Ap f a Pure x -> x forall a. a -> a id) -- | Extract the @f@ out of the 'Ap1'. -- -- @ -- 'retractAp1' . 'liftAp1' == id -- @ retractAp1 :: Apply f => Ap1 f ~> f retractAp1 :: Ap1 f ~> f retractAp1 (Ap1 f a x Ap f (a -> x) xs) = f a -> Ap f (a -> x) -> f x forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b retractAp1_ f a x Ap f (a -> x) xs -- | Interpret an @'Ap' f@ into some 'Apply' context @g@. runAp1 :: Apply g => (f ~> g) -> Ap1 f ~> g runAp1 :: (f ~> g) -> Ap1 f ~> g runAp1 f ~> g f (Ap1 f a x Ap f (a -> x) xs) = (f ~> g) -> f a -> Ap f (a -> x) -> g x forall (f :: * -> *) (g :: * -> *) a b. Apply g => (f ~> g) -> f a -> Ap f (a -> b) -> g b runAp1_ f ~> g f f a x Ap f (a -> x) xs instance HFunctor Ap1 where hmap :: (f ~> g) -> Ap1 f ~> Ap1 g hmap f ~> g f (Ap1 f a x Ap f (a -> x) xs) = g a -> Ap g (a -> x) -> Ap1 g x forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 (f a -> g a f ~> g f f a x) ((f ~> g) -> Ap f (a -> x) -> Ap g (a -> x) forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *). HFunctor t => (f ~> g) -> t f ~> t g hmap f ~> g f Ap f (a -> x) xs) instance Inject Ap1 where inject :: f x -> Ap1 f x inject = f x -> Ap1 f x forall (f :: * -> *). f ~> Ap1 f liftAp1 instance HBind Ap1 where hbind :: (f ~> Ap1 g) -> Ap1 f ~> Ap1 g hbind = (f ~> Ap1 g) -> Ap1 f x -> Ap1 g x forall (g :: * -> *) (f :: * -> *). Apply g => (f ~> g) -> Ap1 f ~> g runAp1 instance HTraversable Ap1 where htraverse :: (forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a) htraverse forall x. f x -> h (g x) f (Ap1 f a x Ap f (a -> a) xs) = g a -> Ap g (a -> a) -> Ap1 g a forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 (g a -> Ap g (a -> a) -> Ap1 g a) -> h (g a) -> h (Ap g (a -> a) -> Ap1 g a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a -> h (g a) forall x. f x -> h (g x) f f a x h (Ap g (a -> a) -> Ap1 g a) -> h (Ap g (a -> a)) -> h (Ap1 g a) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (forall x. f x -> h (g x)) -> Ap f (a -> a) -> h (Ap g (a -> a)) forall k k (t :: (k -> *) -> k -> *) (h :: * -> *) (f :: k -> *) (g :: k -> *) (a :: k). (HTraversable t, Applicative h) => (forall (x :: k). f x -> h (g x)) -> t f a -> h (t g a) htraverse forall x. f x -> h (g x) f Ap f (a -> a) xs instance HTraversable1 Ap1 where htraverse1 :: (forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a) htraverse1 forall x. f x -> h (g x) f (Ap1 f a x Ap f (a -> a) xs) = (forall x. f x -> h (g x)) -> f a -> Ap f (a -> a) -> h (Ap1 g a) forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b. Apply h => (forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b) traverseAp1_ forall x. f x -> h (g x) f f a x Ap f (a -> a) xs traverseAp1_ :: forall f g h a b. Apply h => (forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b) traverseAp1_ :: (forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b) traverseAp1_ forall x. f x -> h (g x) f = f a -> Ap f (a -> b) -> h (Ap1 g b) forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y) go where go :: f x -> Ap f (x -> y) -> h (Ap1 g y) go :: f x -> Ap f (x -> y) -> h (Ap1 g y) go f x x = \case Pure x -> y y -> (g x -> Ap g (x -> y) -> Ap1 g y forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b `Ap1` (x -> y) -> Ap g (x -> y) forall a (f :: * -> *). a -> Ap f a Pure x -> y y) (g x -> Ap1 g y) -> h (g x) -> h (Ap1 g y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f x -> h (g x) forall x. f x -> h (g x) f f x x Ap f a1 y Ap f (a1 -> x -> y) ys -> g x -> Ap g (x -> y) -> Ap1 g y forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b Ap1 (g x -> Ap g (x -> y) -> Ap1 g y) -> h (g x) -> h (Ap g (x -> y) -> Ap1 g y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f x -> h (g x) forall x. f x -> h (g x) f f x x h (Ap g (x -> y) -> Ap1 g y) -> h (Ap g (x -> y)) -> h (Ap1 g y) forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b <.> (Ap1 g (x -> y) -> Ap g (x -> y) forall (f :: * -> *). Ap1 f ~> Ap f toAp (Ap1 g (x -> y) -> Ap g (x -> y)) -> h (Ap1 g (x -> y)) -> h (Ap g (x -> y)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a1 -> Ap f (a1 -> x -> y) -> h (Ap1 g (x -> y)) forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y) go f a1 y Ap f (a1 -> x -> y) ys) instance Apply f => Interpret Ap1 f where retract :: Ap1 f x -> f x retract = Ap1 f x -> f x forall (f :: * -> *). Apply f => Ap1 f ~> f retractAp1 interpret :: (g ~> f) -> Ap1 g ~> f interpret = (g ~> f) -> Ap1 g x -> f x forall (g :: * -> *) (f :: * -> *). Apply g => (f ~> g) -> Ap1 f ~> g runAp1 retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b retractAp1_ :: f a -> Ap f (a -> b) -> f b retractAp1_ f a x = \case Pure a -> b y -> a -> b y (a -> b) -> f a -> f b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a x Ap f a1 y Ap f (a1 -> a -> b) ys -> a -> (a -> b) -> b forall a b. a -> (a -> b) -> b (&) (a -> (a -> b) -> b) -> f a -> f ((a -> b) -> b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a x f ((a -> b) -> b) -> f (a -> b) -> f b forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b <.> f a1 -> Ap f (a1 -> a -> b) -> f (a -> b) forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b retractAp1_ f a1 y Ap f (a1 -> a -> b) ys runAp1_ :: forall f g a b. Apply g => (f ~> g) -> f a -> Ap f (a -> b) -> g b runAp1_ :: (f ~> g) -> f a -> Ap f (a -> b) -> g b runAp1_ f ~> g f = f a -> Ap f (a -> b) -> g b forall x y. f x -> Ap f (x -> y) -> g y go where go :: f x -> Ap f (x -> y) -> g y go :: f x -> Ap f (x -> y) -> g y go f x x = \case Pure x -> y y -> x -> y y (x -> y) -> g x -> g y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f x -> g x f ~> g f f x x Ap f a1 y Ap f (a1 -> x -> y) ys -> x -> (x -> y) -> y forall a b. a -> (a -> b) -> b (&) (x -> (x -> y) -> y) -> g x -> g ((x -> y) -> y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f x -> g x f ~> g f f x x g ((x -> y) -> y) -> g (x -> y) -> g y forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b <.> f a1 -> Ap f (a1 -> x -> y) -> g (x -> y) forall x y. f x -> Ap f (x -> y) -> g y go f a1 y Ap f (a1 -> x -> y) ys