{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}
{-# LANGUAGE
RankNTypes
, TypeFamilies
, TypeOperators
, DeriveFunctor
, DeriveFoldable
, ConstraintKinds
, TemplateHaskell
, DeriveTraversable
, FlexibleInstances
, UndecidableInstances
, QuantifiedConstraints
, MultiParamTypeClasses
#-}
module Data.Functor.Free (
Free(..)
, deriveFreeInstance
, deriveInstances
, unit
, rightAdjunct
, counit
, leftAdjunct
, transform
, unfold
, convert
, convertClosed
, Extract(..)
, Duplicate(..)
, Coproduct
, coproduct
, inL
, inR
, InitialObject
, initial
) where
import Data.Function (fix)
import Data.Monoid (Ap(..))
import Data.Void
import Data.Traversable
import Control.Comonad
import Language.Haskell.TH.Syntax
import Data.Functor.Free.Internal
import Data.DeriveLiftedInstances (ShowsPrec(..), deriveInstance, apDeriv, idDeriv)
newtype Free c a = Free { Free c a -> forall b. c b => (a -> b) -> b
runFree :: forall b. c b => (a -> b) -> b }
unit :: a -> Free c a
unit :: a -> Free c a
unit a
a = (forall b. c b => (a -> b) -> b) -> Free c a
forall (c :: * -> Constraint) a.
(forall b. c b => (a -> b) -> b) -> Free c a
Free ((forall b. c b => (a -> b) -> b) -> Free c a)
-> (forall b. c b => (a -> b) -> b) -> Free c a
forall a b. (a -> b) -> a -> b
$ \a -> b
k -> a -> b
k a
a
rightAdjunct :: c b => (a -> b) -> Free c a -> b
rightAdjunct :: (a -> b) -> Free c a -> b
rightAdjunct a -> b
f Free c a
g = Free c a -> (a -> b) -> b
forall (c :: * -> Constraint) a.
Free c a -> forall b. c b => (a -> b) -> b
runFree Free c a
g a -> b
f
counit :: c a => Free c a -> a
counit :: Free c a -> a
counit = (a -> a) -> Free c a -> a
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct a -> a
forall a. a -> a
id
leftAdjunct :: (Free c a -> b) -> a -> b
leftAdjunct :: (Free c a -> b) -> a -> b
leftAdjunct Free c a -> b
f = Free c a -> b
f (Free c a -> b) -> (a -> Free c a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free c a
forall a (c :: * -> Constraint). a -> Free c a
unit
transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform forall r. c r => (b -> r) -> a -> r
t (Free forall b. c b => (a -> b) -> b
f) = (forall b. c b => (b -> b) -> b) -> Free c b
forall (c :: * -> Constraint) a.
(forall b. c b => (a -> b) -> b) -> Free c a
Free ((a -> b) -> b
forall b. c b => (a -> b) -> b
f ((a -> b) -> b) -> ((b -> b) -> a -> b) -> (b -> b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b) -> a -> b
forall r. c r => (b -> r) -> a -> r
t)
instance Functor (Free c) where
fmap :: (a -> b) -> Free c a -> Free c b
fmap a -> b
f = (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
forall (c :: * -> Constraint) b a.
(forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform ((b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
instance Applicative (Free c) where
pure :: a -> Free c a
pure = a -> Free c a
forall a (c :: * -> Constraint). a -> Free c a
unit
Free c (a -> b)
fs <*> :: Free c (a -> b) -> Free c a -> Free c b
<*> Free c a
as = (forall r. c r => (b -> r) -> (a -> b) -> r)
-> Free c (a -> b) -> Free c b
forall (c :: * -> Constraint) b a.
(forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform (\b -> r
k a -> b
f -> (a -> r) -> Free c a -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct (b -> r
k (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) Free c a
as) Free c (a -> b)
fs
instance Monad (Free c) where
return :: a -> Free c a
return = a -> Free c a
forall a (c :: * -> Constraint). a -> Free c a
unit
Free c a
as >>= :: Free c a -> (a -> Free c b) -> Free c b
>>= a -> Free c b
f = (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
forall (c :: * -> Constraint) b a.
(forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform (\b -> r
k -> (b -> r) -> Free c b -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct b -> r
k (Free c b -> r) -> (a -> Free c b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free c b
f) Free c a
as
instance (forall f x. Applicative f => c (Ap f (Free c x))) => Foldable (Free c) where
foldMap :: (a -> m) -> Free c a -> m
foldMap = (a -> m) -> Free c a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance (forall f x. Applicative f => c (Ap f (Free c x))) => Traversable (Free c) where
traverse :: (a -> f b) -> Free c a -> f (Free c b)
traverse a -> f b
f = Ap f (Free c b) -> f (Free c b)
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap f (Free c b) -> f (Free c b))
-> (Free c a -> Ap f (Free c b)) -> Free c a -> f (Free c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Ap f (Free c b)) -> Free c a -> Ap f (Free c b)
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct (f (Free c b) -> Ap f (Free c b)
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (f (Free c b) -> Ap f (Free c b))
-> (a -> f (Free c b)) -> a -> Ap f (Free c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Free c b) -> f b -> f (Free c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Free c b
forall a (c :: * -> Constraint). a -> Free c a
unit (f b -> f (Free c b)) -> (a -> f b) -> a -> f (Free c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)
instance (Show a, c ShowsPrec) => Show (Free c a) where
showsPrec :: Int -> Free c a -> ShowS
showsPrec Int
p = Int -> ShowsPrec -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (ShowsPrec -> ShowS)
-> (Free c a -> ShowsPrec) -> Free c a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ShowsPrec) -> Free c a -> ShowsPrec
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct (\a
a -> (Int -> ShowS) -> ShowsPrec
ShowsPrec ((Int -> ShowS) -> ShowsPrec) -> (Int -> ShowS) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
d -> Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"pure " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a)
newtype a = { :: a }
newtype Duplicate f a = Duplicate { Duplicate f a -> f (f a)
getDuplicate :: f (f a) }
instance (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))
=> Comonad (Free c) where
extract :: Free c a -> a
extract = Extract a -> a
forall a. Extract a -> a
getExtract (Extract a -> a) -> (Free c a -> Extract a) -> Free c a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Extract a) -> Free c a -> Extract a
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct a -> Extract a
forall a. a -> Extract a
Extract
duplicate :: Free c a -> Free c (Free c a)
duplicate = Duplicate (Free c) a -> Free c (Free c a)
forall (f :: * -> *) a. Duplicate f a -> f (f a)
getDuplicate (Duplicate (Free c) a -> Free c (Free c a))
-> (Free c a -> Duplicate (Free c) a)
-> Free c a
-> Free c (Free c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Duplicate (Free c) a) -> Free c a -> Duplicate (Free c) a
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct (Free c (Free c a) -> Duplicate (Free c) a
forall (f :: * -> *) a. f (f a) -> Duplicate f a
Duplicate (Free c (Free c a) -> Duplicate (Free c) a)
-> (a -> Free c (Free c a)) -> a -> Duplicate (Free c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free c a -> Free c (Free c a)
forall a (c :: * -> Constraint). a -> Free c a
unit (Free c a -> Free c (Free c a))
-> (a -> Free c a) -> a -> Free c (Free c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free c a
forall a (c :: * -> Constraint). a -> Free c a
unit)
unfold :: (b -> Coproduct c b a) -> b -> Free c a
unfold :: (b -> Coproduct c b a) -> b -> Free c a
unfold b -> Coproduct c b a
f = ((b -> Free c a) -> b -> Free c a) -> b -> Free c a
forall a. (a -> a) -> a
fix (((b -> Free c a) -> b -> Free c a) -> b -> Free c a)
-> ((b -> Free c a) -> b -> Free c a) -> b -> Free c a
forall a b. (a -> b) -> a -> b
$ \b -> Free c a
go -> (forall r. c r => (a -> r) -> Either b a -> r)
-> Coproduct c b a -> Free c a
forall (c :: * -> Constraint) b a.
(forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform (\a -> r
k -> (b -> r) -> (a -> r) -> Either b a -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a -> r) -> Free c a -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct a -> r
k (Free c a -> r) -> (b -> Free c a) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Free c a
go) a -> r
k) (Coproduct c b a -> Free c a)
-> (b -> Coproduct c b a) -> b -> Free c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Coproduct c b a
f
convert :: (c (f a), Applicative f) => Free c a -> f a
convert :: Free c a -> f a
convert = (a -> f a) -> Free c a -> f a
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
convertClosed :: c r => Free c Void -> r
convertClosed :: Free c Void -> r
convertClosed = (Void -> r) -> Free c Void -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct Void -> r
forall a. Void -> a
absurd
type Coproduct c m n = Free c (Either m n)
coproduct :: c r => (m -> r) -> (n -> r) -> Coproduct c m n -> r
coproduct :: (m -> r) -> (n -> r) -> Coproduct c m n -> r
coproduct m -> r
m n -> r
n = (Either m n -> r) -> Coproduct c m n -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct ((m -> r) -> (n -> r) -> Either m n -> r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either m -> r
m n -> r
n)
inL :: m -> Coproduct c m n
inL :: m -> Coproduct c m n
inL = Either m n -> Coproduct c m n
forall a (c :: * -> Constraint). a -> Free c a
unit (Either m n -> Coproduct c m n)
-> (m -> Either m n) -> m -> Coproduct c m n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Either m n
forall a b. a -> Either a b
Left
inR :: n -> Coproduct c m n
inR :: n -> Coproduct c m n
inR = Either m n -> Coproduct c m n
forall a (c :: * -> Constraint). a -> Free c a
unit (Either m n -> Coproduct c m n)
-> (n -> Either m n) -> n -> Coproduct c m n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Either m n
forall a b. b -> Either a b
Right
type InitialObject c = Free c Void
initial :: c r => InitialObject c -> r
initial :: InitialObject c -> r
initial = (Void -> r) -> InitialObject c -> r
forall (c :: * -> Constraint) b a. c b => (a -> b) -> Free c a -> b
rightAdjunct Void -> r
forall a. Void -> a
absurd
deriveFreeInstance :: Name -> Q [Dec]
deriveFreeInstance :: Name -> Q [Dec]
deriveFreeInstance = Name -> Name -> Name -> Name -> Q [Dec]
deriveFreeInstance' ''Free 'Free 'runFree
deriveInstances :: Name -> Q [Dec]
deriveInstances :: Name -> Q [Dec]
deriveInstances = Name -> Name -> Name -> Name -> Q [Dec]
deriveInstances' ''Free 'Free 'runFree
deriveFreeInstance' ''Free 'Free 'runFree ''Num
deriveFreeInstance' ''Free 'Free 'runFree ''Fractional
deriveFreeInstance' ''Free 'Free 'runFree ''Floating
deriveFreeInstance' ''Free 'Free 'runFree ''Semigroup
deriveFreeInstance' ''Free 'Free 'runFree ''Monoid
deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Fractional a) => Fractional (Ap f a)|]
deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Floating a) => Floating (Ap f a)|]