{-# 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
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-- A free functor is left adjoint to a forgetful functor.
-- In this package the forgetful functor forgets class constraints.
-----------------------------------------------------------------------------
module Data.Functor.Free (

    Free(..)
  , deriveFreeInstance
  , deriveInstances
  , unit
  , rightAdjunct
  , counit
  , leftAdjunct
  , transform
  , unfold
  , convert
  , convertClosed
  , Extract(..)
  , Duplicate(..)

  -- * Coproducts
  , 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)


-- | The free functor for class @c@.
--
--   @Free c a@ is basically an expression tree with operations from class @c@
--   and variables/placeholders of type @a@, created with `unit`.
--   Monadic bind allows you to replace each of these variables with another sub-expression.
newtype Free c a = Free { Free c a -> forall b. c b => (a -> b) -> b
runFree :: forall b. c b => (a -> b) -> b }

-- | `unit` allows you to create @`Free` c@ values, together with the operations from the class @c@.
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` is the destructor of @`Free` c@ values.
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 = rightAdjunct id@
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 f = f . unit@
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 f as = as >>= f unit@
--
-- @transform f . transform g = transform (g . f)@
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 Extract a = Extract { Extract a -> a
getExtract :: 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 f = coproduct (unfold f) unit . f@
--
-- `inL` and `inR` are useful here. For example, the following creates the list @[1..10]@ as a @Free Monoid@:
--
-- @unfold (\b -> if b == 0 then mempty else `inL` (b - 1) \<> `inR` b) 10@
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 = rightAdjunct pure@
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 = rightAdjunct absurd@
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


-- | Products of @Monoid@s are @Monoid@s themselves. But coproducts of @Monoid@s are not.
-- However, the free @Monoid@ applied to the coproduct /is/ a @Monoid@, and it is the coproduct in the category of @Monoid@s.
-- This is also called the free product, and generalizes to any algebraic class.
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

-- | Derive the instance of @`Free` c a@ for the class @c@.
--
-- For example:
--
-- @deriveFreeInstance ''Num@
deriveFreeInstance :: Name -> Q [Dec]
deriveFreeInstance :: Name -> Q [Dec]
deriveFreeInstance = Name -> Name -> Name -> Name -> Q [Dec]
deriveFreeInstance' ''Free 'Free 'runFree

--- | Derive the instances of @`Free` c a@ for the class @c@, `Show`, `Foldable` and `Traversable`.
--
-- For example:
--
-- @deriveInstances ''Num@
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)|]