{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}

-- | Free @Alternative@ (with no laws beyond monoidal).
--
-- Free 'Alternative' but assumes no laws relating
-- @Applicative@ structure and @Alternative@ methods,
-- just inherited @Applicative@ laws and @(empty, '<|>')@ being
-- monoid.
module Control.Alternative.Free.Lawless(
  -- * Type definitions
  Free(.., SumOf, ApOf),
  Factor(..), Summand(..),
  viewAp, reviewAp, viewSum, reviewSum,

  -- * Universal property
  liftFree, hoistFree, foldFree,

  -- * Auxiliary types
  Ap'(..), toAp, notOneAp
) where

import Control.Applicative (Alternative (..))
import Control.Applicative.Free

import Data.List.NotOne
import Data.Foldable (asum)
import qualified Data.Foldable as F

import FFunctor
import FFunctor.Lift1
import FFunctor.Tannen
import FFunctor.FCompose
import Data.Bifunctor (Bifunctor(..))
import FMonad (FMonad (..))

data Free f a =
    FreeLift (f a)
  | FreeSumOf' (NotOne (Summand f a))
  | FreeApOf'  (Ap' (Factor f) a)
  deriving (forall a b. (a -> b) -> Free f a -> Free f b)
-> (forall a b. a -> Free f b -> Free f a) -> Functor (Free f)
forall a b. a -> Free f b -> Free f a
forall a b. (a -> b) -> Free f a -> Free f b
forall (f :: * -> *) a b. Functor f => a -> Free f b -> Free f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Free f a -> Free f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Free f a -> Free f b
fmap :: forall a b. (a -> b) -> Free f a -> Free f b
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> Free f b -> Free f a
<$ :: forall a b. a -> Free f b -> Free f a
Functor

instance Functor f => Applicative (Free f) where
  pure :: forall a. a -> Free f a
pure = Ap (Factor f) a -> Free f a
forall (f :: * -> *) a. Functor f => Ap (Factor f) a -> Free f a
reviewAp (Ap (Factor f) a -> Free f a)
-> (a -> Ap (Factor f) a) -> a -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Ap (Factor f) a
forall a. a -> Ap (Factor f) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Free f (a -> b)
x <*> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
<*> Free f a
y = Ap (Factor f) b -> Free f b
forall (f :: * -> *) a. Functor f => Ap (Factor f) a -> Free f a
reviewAp (Free f (a -> b) -> Ap (Factor f) (a -> b)
forall (f :: * -> *) a. Free f a -> Ap (Factor f) a
viewAp Free f (a -> b)
x Ap (Factor f) (a -> b) -> Ap (Factor f) a -> Ap (Factor f) b
forall a b.
Ap (Factor f) (a -> b) -> Ap (Factor f) a -> Ap (Factor f) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Free f a -> Ap (Factor f) a
forall (f :: * -> *) a. Free f a -> Ap (Factor f) a
viewAp Free f a
y)

instance Functor f => Alternative (Free f) where
  empty :: forall a. Free f a
empty = [Summand f a] -> Free f a
forall (f :: * -> *) a. [Summand f a] -> Free f a
reviewSum [Summand f a]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
  Free f a
x <|> :: forall a. Free f a -> Free f a -> Free f a
<|> Free f a
y = [Summand f a] -> Free f a
forall (f :: * -> *) a. [Summand f a] -> Free f a
reviewSum (Free f a -> [Summand f a]
forall (f :: * -> *) a. Free f a -> [Summand f a]
viewSum Free f a
x [Summand f a] -> [Summand f a] -> [Summand f a]
forall a. [a] -> [a] -> [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Free f a -> [Summand f a]
forall (f :: * -> *) a. Free f a -> [Summand f a]
viewSum Free f a
y)

instance FFunctor Free where
  ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Free g x -> Free h x
ffmap = (forall x. g x -> h x) -> Free g x -> Free h x
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Free f a -> Free g a
hoistFree

instance FMonad Free where
  fpure :: forall (g :: * -> *). Functor g => g ~> Free g
fpure = g x -> Free g x
forall (f :: * -> *) a. f a -> Free f a
liftFree
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Free h) -> Free g a -> Free h a
fbind = (forall x. g x -> Free h x) -> Free g a -> Free h a
forall (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Free f a -> g a
foldFree

-- | View as a list of 'Summand's
pattern SumOf :: [Summand f a] -> Free f a
pattern $mSumOf :: forall {r} {f :: * -> *} {a}.
Free f a -> ([Summand f a] -> r) -> ((# #) -> r) -> r
$bSumOf :: forall (f :: * -> *) a. [Summand f a] -> Free f a
SumOf fas <- (viewSum -> fas)
  where SumOf [Summand f a]
fas = [Summand f a] -> Free f a
forall (f :: * -> *) a. [Summand f a] -> Free f a
reviewSum [Summand f a]
fas

viewSum :: Free f a -> [Summand f a]
viewSum :: forall (f :: * -> *) a. Free f a -> [Summand f a]
viewSum Free f a
e = case Free f a
e of
 FreeLift f a
fa -> Summand f a -> [Summand f a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summand f a -> [Summand f a])
-> (f a -> Summand f a) -> f a -> [Summand f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (f a) (Ap' (Factor f) a) -> Summand f a
forall (f :: * -> *) a.
Either (f a) (Ap' (Factor f) a) -> Summand f a
Summand (Either (f a) (Ap' (Factor f) a) -> Summand f a)
-> (f a -> Either (f a) (Ap' (Factor f) a)) -> f a -> Summand f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Either (f a) (Ap' (Factor f) a)
forall a b. a -> Either a b
Left (f a -> [Summand f a]) -> f a -> [Summand f a]
forall a b. (a -> b) -> a -> b
$ f a
fa
 FreeSumOf' NotOne (Summand f a)
fas -> NotOne (Summand f a) -> [Summand f a]
forall a. NotOne a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList NotOne (Summand f a)
fas
 FreeApOf' Ap' (Factor f) a
fas -> Summand f a -> [Summand f a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Summand f a -> [Summand f a])
-> (Ap' (Factor f) a -> Summand f a)
-> Ap' (Factor f) a
-> [Summand f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (f a) (Ap' (Factor f) a) -> Summand f a
forall (f :: * -> *) a.
Either (f a) (Ap' (Factor f) a) -> Summand f a
Summand (Either (f a) (Ap' (Factor f) a) -> Summand f a)
-> (Ap' (Factor f) a -> Either (f a) (Ap' (Factor f) a))
-> Ap' (Factor f) a
-> Summand f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap' (Factor f) a -> Either (f a) (Ap' (Factor f) a)
forall a b. b -> Either a b
Right (Ap' (Factor f) a -> [Summand f a])
-> Ap' (Factor f) a -> [Summand f a]
forall a b. (a -> b) -> a -> b
$ Ap' (Factor f) a
fas

reviewSum :: [Summand f a] -> Free f a
reviewSum :: forall (f :: * -> *) a. [Summand f a] -> Free f a
reviewSum = (Summand f a -> Free f a)
-> (NotOne (Summand f a) -> Free f a)
-> Either (Summand f a) (NotOne (Summand f a))
-> Free f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Summand f a -> Free f a
forall (f :: * -> *) a. Summand f a -> Free f a
injectSummand NotOne (Summand f a) -> Free f a
forall (f :: * -> *) a. NotOne (Summand f a) -> Free f a
FreeSumOf' (Either (Summand f a) (NotOne (Summand f a)) -> Free f a)
-> ([Summand f a] -> Either (Summand f a) (NotOne (Summand f a)))
-> [Summand f a]
-> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Summand f a] -> Either (Summand f a) (NotOne (Summand f a))
forall a. [a] -> Either a (NotOne a)
notOne
  where
    injectSummand :: Summand f a -> Free f a
    injectSummand :: forall (f :: * -> *) a. Summand f a -> Free f a
injectSummand = (f a -> Free f a)
-> (Ap' (Factor f) a -> Free f a)
-> Either (f a) (Ap' (Factor f) a)
-> Free f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f a -> Free f a
forall (f :: * -> *) a. f a -> Free f a
FreeLift Ap' (Factor f) a -> Free f a
forall (f :: * -> *) a. Ap' (Factor f) a -> Free f a
FreeApOf' (Either (f a) (Ap' (Factor f) a) -> Free f a)
-> (Summand f a -> Either (f a) (Ap' (Factor f) a))
-> Summand f a
-> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summand f a -> Either (f a) (Ap' (Factor f) a)
forall (f :: * -> *) a.
Summand f a -> Either (f a) (Ap' (Factor f) a)
runSummand

-- | View as a @Ap@, formal chain of @<*>@, of 'Factor's.
pattern ApOf :: Functor f => () => Ap (Factor f) a -> Free f a
pattern $mApOf :: forall {r} {f :: * -> *} {a}.
Functor f =>
Free f a -> (Ap (Factor f) a -> r) -> ((# #) -> r) -> r
$bApOf :: forall (f :: * -> *) a. Functor f => Ap (Factor f) a -> Free f a
ApOf fas <- (viewAp -> fas)
  where ApOf Ap (Factor f) a
fas = Ap (Factor f) a -> Free f a
forall (f :: * -> *) a. Functor f => Ap (Factor f) a -> Free f a
reviewAp Ap (Factor f) a
fas

viewAp :: Free f a -> Ap (Factor f) a
viewAp :: forall (f :: * -> *) a. Free f a -> Ap (Factor f) a
viewAp Free f a
e = case Free f a
e of
  FreeLift f a
fa -> Factor f a -> Ap (Factor f) a
forall (f :: * -> *) a. f a -> Ap f a
liftAp (Factor f a -> Ap (Factor f) a)
-> (f a -> Factor f a) -> f a -> Ap (Factor f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (f a) (NotOne (Summand f a)) -> Factor f a
forall (f :: * -> *) a.
Either (f a) (NotOne (Summand f a)) -> Factor f a
Factor (Either (f a) (NotOne (Summand f a)) -> Factor f a)
-> (f a -> Either (f a) (NotOne (Summand f a)))
-> f a
-> Factor f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Either (f a) (NotOne (Summand f a))
forall a b. a -> Either a b
Left (f a -> Ap (Factor f) a) -> f a -> Ap (Factor f) a
forall a b. (a -> b) -> a -> b
$ f a
fa
  FreeSumOf' NotOne (Summand f a)
fas -> Factor f a -> Ap (Factor f) a
forall (f :: * -> *) a. f a -> Ap f a
liftAp (Factor f a -> Ap (Factor f) a)
-> (NotOne (Summand f a) -> Factor f a)
-> NotOne (Summand f a)
-> Ap (Factor f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (f a) (NotOne (Summand f a)) -> Factor f a
forall (f :: * -> *) a.
Either (f a) (NotOne (Summand f a)) -> Factor f a
Factor (Either (f a) (NotOne (Summand f a)) -> Factor f a)
-> (NotOne (Summand f a) -> Either (f a) (NotOne (Summand f a)))
-> NotOne (Summand f a)
-> Factor f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotOne (Summand f a) -> Either (f a) (NotOne (Summand f a))
forall a b. b -> Either a b
Right (NotOne (Summand f a) -> Ap (Factor f) a)
-> NotOne (Summand f a) -> Ap (Factor f) a
forall a b. (a -> b) -> a -> b
$ NotOne (Summand f a)
fas
  FreeApOf' Ap' (Factor f) a
fas -> Ap' (Factor f) a -> Ap (Factor f) a
forall (f :: * -> *) a. Ap' f a -> Ap f a
toAp Ap' (Factor f) a
fas

reviewAp :: Functor f => Ap (Factor f) a -> Free f a
reviewAp :: forall (f :: * -> *) a. Functor f => Ap (Factor f) a -> Free f a
reviewAp = (Factor f a -> Free f a)
-> (Ap' (Factor f) a -> Free f a)
-> Either (Factor f a) (Ap' (Factor f) a)
-> Free f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Factor f a -> Free f a
forall (f :: * -> *) a. Factor f a -> Free f a
injectFactor Ap' (Factor f) a -> Free f a
forall (f :: * -> *) a. Ap' (Factor f) a -> Free f a
FreeApOf' (Either (Factor f a) (Ap' (Factor f) a) -> Free f a)
-> (Ap (Factor f) a -> Either (Factor f a) (Ap' (Factor f) a))
-> Ap (Factor f) a
-> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap (Factor f) a -> Either (Factor f a) (Ap' (Factor f) a)
forall (f :: * -> *) a.
Functor f =>
Ap f a -> Either (f a) (Ap' f a)
notOneAp
  where
    injectFactor :: Factor f a -> Free f a
    injectFactor :: forall (f :: * -> *) a. Factor f a -> Free f a
injectFactor = (f a -> Free f a)
-> (NotOne (Summand f a) -> Free f a)
-> Either (f a) (NotOne (Summand f a))
-> Free f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f a -> Free f a
forall (f :: * -> *) a. f a -> Free f a
FreeLift NotOne (Summand f a) -> Free f a
forall (f :: * -> *) a. NotOne (Summand f a) -> Free f a
FreeSumOf' (Either (f a) (NotOne (Summand f a)) -> Free f a)
-> (Factor f a -> Either (f a) (NotOne (Summand f a)))
-> Factor f a
-> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Factor f a -> Either (f a) (NotOne (Summand f a))
forall (f :: * -> *) a.
Factor f a -> Either (f a) (NotOne (Summand f a))
runFactor

-- | Subexpressions of @Free f a@ which cannot be written as
-- nontrivial sum @x '<|>' y@.
newtype Summand f a = Summand { forall (f :: * -> *) a.
Summand f a -> Either (f a) (Ap' (Factor f) a)
runSummand :: Either (f a) (Ap' (Factor f) a) }
  deriving ((forall a b. (a -> b) -> Summand f a -> Summand f b)
-> (forall a b. a -> Summand f b -> Summand f a)
-> Functor (Summand f)
forall a b. a -> Summand f b -> Summand f a
forall a b. (a -> b) -> Summand f a -> Summand f b
forall (f :: * -> *) a b.
Functor f =>
a -> Summand f b -> Summand f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Summand f a -> Summand f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Summand f a -> Summand f b
fmap :: forall a b. (a -> b) -> Summand f a -> Summand f b
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> Summand f b -> Summand f a
<$ :: forall a b. a -> Summand f b -> Summand f a
Functor) via Lift1 (FCompose Ap' Factor) f
  deriving ((forall (f :: * -> *). Functor f => Functor (Summand f)) =>
(forall (g :: * -> *) (h :: * -> *) x.
 (Functor g, Functor h) =>
 (g ~> h) -> Summand g x -> Summand h x)
-> FFunctor Summand
forall (f :: * -> *). Functor f => Functor (Summand f)
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Summand g x -> Summand h x
forall (ff :: FF).
(forall (g :: * -> *). Functor g => Functor (ff g)) =>
(forall (g :: * -> *) (h :: * -> *) x.
 (Functor g, Functor h) =>
 (g ~> h) -> ff g x -> ff h x)
-> FFunctor ff
$cffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Summand g x -> Summand h x
ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Summand g x -> Summand h x
FFunctor) via Lift1 (FCompose Ap' Factor)

-- | Subexpressions of @Free f a@ which cannot be written as
-- nontrivial apply @x '<*>' y@.
newtype Factor f a = Factor { forall (f :: * -> *) a.
Factor f a -> Either (f a) (NotOne (Summand f a))
runFactor :: Either (f a) (NotOne (Summand f a)) }
  deriving ((forall a b. (a -> b) -> Factor f a -> Factor f b)
-> (forall a b. a -> Factor f b -> Factor f a)
-> Functor (Factor f)
forall a b. a -> Factor f b -> Factor f a
forall a b. (a -> b) -> Factor f a -> Factor f b
forall (f :: * -> *) a b.
Functor f =>
a -> Factor f b -> Factor f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Factor f a -> Factor f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Factor f a -> Factor f b
fmap :: forall a b. (a -> b) -> Factor f a -> Factor f b
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> Factor f b -> Factor f a
<$ :: forall a b. a -> Factor f b -> Factor f a
Functor) via Lift1 (Tannen NotOne Summand) f
  deriving ((forall (f :: * -> *). Functor f => Functor (Factor f)) =>
(forall (g :: * -> *) (h :: * -> *) x.
 (Functor g, Functor h) =>
 (g ~> h) -> Factor g x -> Factor h x)
-> FFunctor Factor
forall (f :: * -> *). Functor f => Functor (Factor f)
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Factor g x -> Factor h x
forall (ff :: FF).
(forall (g :: * -> *). Functor g => Functor (ff g)) =>
(forall (g :: * -> *) (h :: * -> *) x.
 (Functor g, Functor h) =>
 (g ~> h) -> ff g x -> ff h x)
-> FFunctor ff
$cffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Factor g x -> Factor h x
ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Factor g x -> Factor h x
FFunctor) via Lift1 (Tannen NotOne Summand)

liftFree :: f a -> Free f a
liftFree :: forall (f :: * -> *) a. f a -> Free f a
liftFree = f a -> Free f a
forall (f :: * -> *) a. f a -> Free f a
FreeLift

hoistFree :: forall f g a. (forall x. f x -> g x) -> Free f a -> Free g a
hoistFree :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Free f a -> Free g a
hoistFree forall x. f x -> g x
fg Free f a
e = case Free f a
e of
  FreeLift f a
fa -> g a -> Free g a
forall (f :: * -> *) a. f a -> Free f a
FreeLift (f a -> g a
forall x. f x -> g x
fg f a
fa)
  FreeSumOf' NotOne (Summand f a)
fas -> NotOne (Summand g a) -> Free g a
forall (f :: * -> *) a. NotOne (Summand f a) -> Free f a
FreeSumOf' ((Summand f a -> Summand g a)
-> NotOne (Summand f a) -> NotOne (Summand g a)
forall a b. (a -> b) -> NotOne a -> NotOne b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Summand f a -> Summand g a
forall b. Summand f b -> Summand g b
goSummand NotOne (Summand f a)
fas)
  FreeApOf' Ap' (Factor f) a
fas -> Ap' (Factor g) a -> Free g a
forall (f :: * -> *) a. Ap' (Factor f) a -> Free f a
FreeApOf' ((forall x. Factor f x -> Factor g x)
-> Ap' (Factor f) a -> Ap' (Factor g) a
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ap' f a -> Ap' g a
hoistAp' Factor f x -> Factor g x
forall x. Factor f x -> Factor g x
goFactor Ap' (Factor f) a
fas)
  where
    goSummand :: forall b. Summand f b -> Summand g b
    goSummand :: forall b. Summand f b -> Summand g b
goSummand = Either (g b) (Ap' (Factor g) b) -> Summand g b
forall (f :: * -> *) a.
Either (f a) (Ap' (Factor f) a) -> Summand f a
Summand (Either (g b) (Ap' (Factor g) b) -> Summand g b)
-> (Summand f b -> Either (g b) (Ap' (Factor g) b))
-> Summand f b
-> Summand g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f b -> g b)
-> (Ap' (Factor f) b -> Ap' (Factor g) b)
-> Either (f b) (Ap' (Factor f) b)
-> Either (g b) (Ap' (Factor g) b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap f b -> g b
forall x. f x -> g x
fg ((forall x. Factor f x -> Factor g x)
-> Ap' (Factor f) b -> Ap' (Factor g) b
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ap' f a -> Ap' g a
hoistAp' Factor f x -> Factor g x
forall x. Factor f x -> Factor g x
goFactor) (Either (f b) (Ap' (Factor f) b)
 -> Either (g b) (Ap' (Factor g) b))
-> (Summand f b -> Either (f b) (Ap' (Factor f) b))
-> Summand f b
-> Either (g b) (Ap' (Factor g) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summand f b -> Either (f b) (Ap' (Factor f) b)
forall (f :: * -> *) a.
Summand f a -> Either (f a) (Ap' (Factor f) a)
runSummand

    goFactor :: forall b. Factor f b -> Factor g b
    goFactor :: forall x. Factor f x -> Factor g x
goFactor = Either (g b) (NotOne (Summand g b)) -> Factor g b
forall (f :: * -> *) a.
Either (f a) (NotOne (Summand f a)) -> Factor f a
Factor (Either (g b) (NotOne (Summand g b)) -> Factor g b)
-> (Factor f b -> Either (g b) (NotOne (Summand g b)))
-> Factor f b
-> Factor g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f b -> g b)
-> (NotOne (Summand f b) -> NotOne (Summand g b))
-> Either (f b) (NotOne (Summand f b))
-> Either (g b) (NotOne (Summand g b))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap f b -> g b
forall x. f x -> g x
fg ((Summand f b -> Summand g b)
-> NotOne (Summand f b) -> NotOne (Summand g b)
forall a b. (a -> b) -> NotOne a -> NotOne b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Summand f b -> Summand g b
forall b. Summand f b -> Summand g b
goSummand) (Either (f b) (NotOne (Summand f b))
 -> Either (g b) (NotOne (Summand g b)))
-> (Factor f b -> Either (f b) (NotOne (Summand f b)))
-> Factor f b
-> Either (g b) (NotOne (Summand g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Factor f b -> Either (f b) (NotOne (Summand f b))
forall (f :: * -> *) a.
Factor f a -> Either (f a) (NotOne (Summand f a))
runFactor

foldFree :: forall f g a. Alternative g => (forall x. f x -> g x) -> Free f a -> g a
foldFree :: forall (f :: * -> *) (g :: * -> *) a.
Alternative g =>
(forall x. f x -> g x) -> Free f a -> g a
foldFree forall x. f x -> g x
fg Free f a
e = case Free f a
e of
  FreeLift f a
fa -> f a -> g a
forall x. f x -> g x
fg f a
fa
  FreeSumOf' NotOne (Summand f a)
fas -> NotOne (g a) -> g a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Summand f a -> g a
forall b. Summand f b -> g b
goSummand (Summand f a -> g a) -> NotOne (Summand f a) -> NotOne (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NotOne (Summand f a)
fas)
  FreeApOf' Ap' (Factor f) a
fas -> (forall x. Factor f x -> g x) -> Ap (Factor f) a -> g a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp Factor f x -> g x
forall x. Factor f x -> g x
goFactor (Ap' (Factor f) a -> Ap (Factor f) a
forall (f :: * -> *) a. Ap' f a -> Ap f a
toAp Ap' (Factor f) a
fas)
  where
    goSummand :: forall b. Summand f b -> g b
    goSummand :: forall b. Summand f b -> g b
goSummand = (f b -> g b)
-> (Ap' (Factor f) b -> g b)
-> Either (f b) (Ap' (Factor f) b)
-> g b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f b -> g b
forall x. f x -> g x
fg ((forall x. Factor f x -> g x) -> Ap (Factor f) b -> g b
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp Factor f x -> g x
forall x. Factor f x -> g x
goFactor (Ap (Factor f) b -> g b)
-> (Ap' (Factor f) b -> Ap (Factor f) b) -> Ap' (Factor f) b -> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap' (Factor f) b -> Ap (Factor f) b
forall (f :: * -> *) a. Ap' f a -> Ap f a
toAp) (Either (f b) (Ap' (Factor f) b) -> g b)
-> (Summand f b -> Either (f b) (Ap' (Factor f) b))
-> Summand f b
-> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summand f b -> Either (f b) (Ap' (Factor f) b)
forall (f :: * -> *) a.
Summand f a -> Either (f a) (Ap' (Factor f) a)
runSummand

    goFactor :: forall b. Factor f b -> g b
    goFactor :: forall x. Factor f x -> g x
goFactor = (f b -> g b)
-> (NotOne (Summand f b) -> g b)
-> Either (f b) (NotOne (Summand f b))
-> g b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f b -> g b
forall x. f x -> g x
fg (NotOne (g b) -> g b
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (NotOne (g b) -> g b)
-> (NotOne (Summand f b) -> NotOne (g b))
-> NotOne (Summand f b)
-> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Summand f b -> g b) -> NotOne (Summand f b) -> NotOne (g b)
forall a b. (a -> b) -> NotOne a -> NotOne b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Summand f b -> g b
forall b. Summand f b -> g b
goSummand) (Either (f b) (NotOne (Summand f b)) -> g b)
-> (Factor f b -> Either (f b) (NotOne (Summand f b)))
-> Factor f b
-> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Factor f b -> Either (f b) (NotOne (Summand f b))
forall (f :: * -> *) a.
Factor f a -> Either (f a) (NotOne (Summand f a))
runFactor

-- * Aux

-- | Free Applicative @'Ap' f a@ but @'liftAp' fa@, is excluded.
--
-- @'Ap' f a@ uses zero or more values of @f _@,
-- but @Ap' f a@ uses either none (`Pure'`) or 2+ times (`ApMany'`).
data Ap' f a where
  Pure' :: a -> Ap' f a
  ApMany' :: f a -> f b -> Ap f (b -> a -> c) -> Ap' f c

deriving instance Functor f => Functor (Ap' f) 

instance FFunctor Ap' where
  ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Ap' g x -> Ap' h x
ffmap = (forall x. g x -> h x) -> Ap' g x -> Ap' h x
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ap' f a -> Ap' g a
hoistAp'

hoistAp' :: (forall x. f x -> g x) -> Ap' f a -> Ap' g a
hoistAp' :: forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Ap' f a -> Ap' g a
hoistAp' forall x. f x -> g x
_ (Pure' a
a) = a -> Ap' g a
forall a (f :: * -> *). a -> Ap' f a
Pure' a
a
hoistAp' forall x. f x -> g x
fg (ApMany' f a
fa f b
fb Ap f (b -> a -> a)
rest) = g a -> g b -> Ap g (b -> a -> a) -> Ap' g a
forall (f :: * -> *) a b c.
f a -> f b -> Ap f (b -> a -> c) -> Ap' f c
ApMany' (f a -> g a
forall x. f x -> g x
fg f a
fa) (f b -> g b
forall x. f x -> g x
fg f b
fb) ((forall x. f x -> g x) -> Ap f (b -> a -> a) -> Ap g (b -> a -> a)
forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Ap f b -> Ap g b
hoistAp f a -> g a
forall x. f x -> g x
fg Ap f (b -> a -> a)
rest)

toAp :: Ap' f a -> Ap f a
toAp :: forall (f :: * -> *) a. Ap' f a -> Ap f a
toAp (Pure' a
a) = a -> Ap f a
forall a (f :: * -> *). a -> Ap f a
Pure a
a
toAp (ApMany' f a
fa f b
fb Ap f (b -> a -> a)
rest) = f a -> Ap f (a -> a) -> Ap f a
forall (f :: * -> *) a1 a. f a1 -> Ap f (a1 -> a) -> Ap f a
Ap f a
fa (f b -> Ap f (b -> a -> a) -> Ap f (a -> a)
forall (f :: * -> *) a1 a. f a1 -> Ap f (a1 -> a) -> Ap f a
Ap f b
fb Ap f (b -> a -> a)
rest)

notOneAp :: Functor f => Ap f a -> Either (f a) (Ap' f a)
notOneAp :: forall (f :: * -> *) a.
Functor f =>
Ap f a -> Either (f a) (Ap' f a)
notOneAp (Pure a
a) = Ap' f a -> Either (f a) (Ap' f a)
forall a b. b -> Either a b
Right (a -> Ap' f a
forall a (f :: * -> *). a -> Ap' f a
Pure' a
a)
notOneAp (Ap f a1
fa (Pure a1 -> a
k)) = f a -> Either (f a) (Ap' f a)
forall a b. a -> Either a b
Left (a1 -> a
k (a1 -> a) -> f a1 -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1
fa)
notOneAp (Ap f a1
fa (Ap f a1
fb Ap f (a1 -> a1 -> a)
rest)) = Ap' f a -> Either (f a) (Ap' f a)
forall a b. b -> Either a b
Right (f a1 -> f a1 -> Ap f (a1 -> a1 -> a) -> Ap' f a
forall (f :: * -> *) a b c.
f a -> f b -> Ap f (b -> a -> c) -> Ap' f c
ApMany' f a1
fa f a1
fb Ap f (a1 -> a1 -> a)
rest)