{-# LANGUAGE
RankNTypes
, TypeOperators
, DeriveFunctor
, DeriveFoldable
, ConstraintKinds
, TemplateHaskell
, DeriveTraversable
, FlexibleInstances
, ScopedTypeVariables
, UndecidableInstances
, QuantifiedConstraints
, MultiParamTypeClasses
, UndecidableSuperClasses
#-}
module Data.Functor.Free.Internal where
import Control.Comonad
import Data.Algebra
import Data.Algebra.TH
import Language.Haskell.TH.Syntax
import Data.Traversable
newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }
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
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)
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
newtype Extract a = Extract { getExtract :: a }
newtype Duplicate f a = Duplicate { getDuplicate :: f (f a) }
instance (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))
=> Comonad (Free c) where
extract = getExtract . rightAdjunct Extract
duplicate = getDuplicate . rightAdjunct (Duplicate . unit . unit)
class (Class f x) => Class' f x where evaluate' :: AlgebraSignature f => f x -> x
instance (Class f x) => Class' f x where evaluate' = evaluate
newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }
instance (forall x. c x => Class' f x) => Algebra f (Free c a) where
algebra fa = Free $ \k -> evaluate' (fmap (rightAdjunct k) fa)
instance (Applicative f, forall x. c x => Class' s x) => Algebra s (LiftAFree c f a) where
algebra = LiftAFree . fmap algebra . traverse getLiftAFree
instance (forall f x. Applicative f => c (LiftAFree c f x)) => Foldable (Free c) where
foldMap = foldMapDefault
instance (forall f x. Applicative f => c (LiftAFree c f x)) => Traversable (Free c) where
traverse f = getLiftAFree . rightAdjunct (LiftAFree . fmap unit . f)
data ShowHelper f a = ShowUnit a | ShowRec (f (ShowHelper f a))
instance Algebra f (ShowHelper f a) where
algebra = ShowRec
instance (Show a, Show (f (ShowHelper f a))) => Show (ShowHelper f a) where
showsPrec p (ShowUnit a) = showParen (p > 10) $ showString "unit " . showsPrec 11 a
showsPrec p (ShowRec f) = showsPrec p f
instance (Show a, Show (Signature c (ShowHelper (Signature c) a)), c (ShowHelper (Signature c) a)) => Show (Free c a) where
showsPrec p = showsPrec p . rightAdjunct (ShowUnit :: a -> ShowHelper (Signature c) a)
class (a => b) => a :=> b
instance (a => b) => a :=> b
deriveInstances :: Name -> Q [Dec]
deriveInstances nm = getSignatureInfo nm >>= h where
h sigInfo =
concat <$> sequenceA
[ deriveSignature nm
, deriveInstanceWith_skipSignature freeHeader $ return []
, deriveInstanceWith_skipSignature liftAFreeHeader $ return []
, deriveInstanceWith_skipSignature showHelperHeader $ return []
, deriveSuperclassInstances showHelperHeader
]
where
freeHeader = [t|forall a c. (forall x. c x :=> $clss x) => $clss (Free c a)|]
liftAFreeHeader = [t|forall f a c. (Applicative f, forall x. c x :=> $clss x) => $clss (LiftAFree c f a)|]
showHelperHeader = [t|forall a. $clss (ShowHelper $sig a)|]
clss = pure $ ConT nm
sig = pure . ConT $ signatureName sigInfo