module Data.Functor.Free (
Free(..)
, deriveInstances
, unit
, rightAdjunct
, rightAdjunctF
, counit
, leftAdjunct
, transform
, unfold
, convert
, convertClosed
, Extract(..)
, Duplicate(..)
, Coproduct
, coproduct
, inL
, inR
, InitialObject
, initial
) where
import Control.Comonad
import Data.Function
import Data.Constraint hiding (Class)
import Data.Constraint.Forall
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 }
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
class ForallLifted c where
dictLifted :: Applicative f => Dict (c (LiftAFree c f a))
rightAdjunctLifted :: (ForallLifted c, Applicative f) => (a -> LiftAFree c f b) -> Free c a -> LiftAFree c f b
rightAdjunctLifted = h dictLifted rightAdjunct
where
h :: Dict (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 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
newtype Extract a = Extract { getExtract :: a }
newtype Duplicate f a = Duplicate { getDuplicate :: f (f a) }
instance (ForallF c Extract, ForallF c (Duplicate (Free c)))
=> Comonad (Free c) where
extract = getExtract . rightAdjunctF Extract
duplicate = getDuplicate . rightAdjunctF (Duplicate . unit . unit)
instance c ~ Class f => Algebra f (Free c a) where
algebra fa = Free $ \k -> evaluate (fmap (rightAdjunct k) fa)
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
deriveInstances :: Name -> Q [Dec]
deriveInstances nm = concat <$> sequenceA
[ deriveSignature nm
, deriveInstanceWith_skipSignature freeHeader $ return []
, deriveInstanceWith_skipSignature liftAFreeHeader $ return []
, deriveInstanceWith_skipSignature showHelperHeader $ return []
, [d|instance ForallLifted $(return c) where dictLifted = Dict|]
]
where
freeHeader = return $ ForallT [PlainTV a] []
(AppT c (AppT (AppT free c) (VarT a)))
liftAFreeHeader = return $ ForallT [PlainTV f,PlainTV a] [AppT (ConT ''Applicative) (VarT f)]
(AppT c (AppT (AppT (AppT liftAFree c) (VarT f)) (VarT a)))
showHelperHeader = return $ ForallT [PlainTV a] []
(AppT c (AppT (AppT showHelper sig) (VarT a)))
free = ConT ''Free
liftAFree = ConT ''LiftAFree
showHelper = ConT ''ShowHelper
c = ConT nm
sig = ConT $ mkName (nameBase nm ++ "Signature")
a = mkName "a"
f = mkName "f"
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 ForallLifted c => Foldable (Free c) where
foldMap = foldMapDefault
instance ForallLifted c => Traversable (Free c) where
traverse f = getLiftAFree . rightAdjunctLifted (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)