module Data.Functor.Free where
import Control.Applicative
import Control.Comonad
import Data.Function
import Data.Constraint hiding (Class)
import Data.Constraint.Forall
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Foldable (Foldable(..))
import Data.Traversable
import Data.Void
import Data.Algebra
import Data.Algebra.TH
import Language.Haskell.TH.Syntax
newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }
deriveInstances :: Name -> Q [Dec]
deriveInstances nm = concat <$> sequenceA
[ deriveSignature nm
, deriveInstanceWith_skipSignature freeHeader $ return []
, deriveInstanceWith_skipSignature liftAFreeHeader $ return []
]
where
freeHeader = return $ ForallT [PlainTV a] []
(AppT c (AppT (AppT free c) (VarT a)))
liftAFreeHeader = return $ ForallT [PlainTV f,PlainTV a] [ClassP ''Applicative [VarT f]]
(AppT c (AppT (AppT (AppT liftAFree c) (VarT f)) (VarT a)))
free = ConT ''Free
liftAFree = ConT ''LiftAFree
c = ConT nm
a = mkName "a"
f = mkName "f"
unit :: a -> Free c a
unit a = Free $ \k -> k a
rightAdjunct :: c b => (a -> b) -> Free c a -> b
rightAdjunct f g = runFree g f
rightAdjunctF :: ForallF c f => (a -> f b) -> Free c a -> f b
rightAdjunctF = h instF rightAdjunct
where
h :: ForallF c f
=> (ForallF c f :- c (f b))
-> (c (f b) => (a -> f b) -> Free c a -> f b)
-> (a -> f b) -> Free c a -> f b
h (Sub Dict) f = f
rightAdjunctT :: ForallT c t => (a -> t f b) -> Free c a -> t f b
rightAdjunctT = h instT rightAdjunct
where
h :: ForallT c t
=> (ForallT c t :- c (t f b))
-> (c (t f b) => (a -> t f b) -> Free c a -> t f b)
-> (a -> t f b) -> Free c a -> t f b
h (Sub Dict) f = f
counit :: c a => Free c a -> a
counit = rightAdjunct id
leftAdjunct :: (Free c a -> b) -> a -> b
leftAdjunct f = f . unit
transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
transform t (Free f) = Free (f . t)
unfold :: (b -> Coproduct c b a) -> b -> Free c a
unfold f = fix $ \go -> transform (\k -> either (rightAdjunct k . go) k) . f
convert :: (c (f a), Applicative f) => Free c a -> f a
convert = rightAdjunct pure
convertClosed :: c r => Free c Void -> r
convertClosed = rightAdjunct absurd
instance Functor (Free c) where
fmap f = transform (. f)
instance Applicative (Free c) where
pure = unit
fs <*> as = transform (\k f -> rightAdjunct (k . f) as) fs
instance Monad (Free c) where
return = unit
as >>= f = transform (\k -> rightAdjunct k . f) as
instance (ForallF c Identity, ForallF c (Compose (Free c) (Free c)))
=> Comonad (Free c) where
extract = runIdentity . rightAdjunctF Identity
duplicate = getCompose . rightAdjunctF (Compose . unit . unit)
instance c ~ Class f => Algebra f (Free c a) where
algebra fa = Free $ \k -> evaluate (fmap (rightAdjunct k) fa)
newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }
instance (Applicative f, c ~ Class s) => Algebra s (LiftAFree c f a) where
algebra = LiftAFree . fmap algebra . traverse getLiftAFree
instance ForallT c (LiftAFree c) => Foldable (Free c) where
foldMap = foldMapDefault
instance ForallT c (LiftAFree c) => Traversable (Free c) where
traverse f = getLiftAFree . rightAdjunctT (LiftAFree . fmap unit . f)
type Coproduct c m n = Free c (Either m n)
coproduct :: c r => (m -> r) -> (n -> r) -> Coproduct c m n -> r
coproduct m n = rightAdjunct (either m n)
inL :: m -> Coproduct c m n
inL = unit . Left
inR :: n -> Coproduct c m n
inR = unit . Right
type InitialObject c = Free c Void
initial :: c r => InitialObject c -> r
initial = rightAdjunct absurd