diff --git a/examples/FreeNum.hs b/examples/FreeNum.hs --- a/examples/FreeNum.hs +++ b/examples/FreeNum.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-} module FreeNum where import Data.Functor.Free - deriveInstances ''Num @@ -11,6 +10,7 @@ x = return "x" y = return "y" +-- try showing expr expr :: Free Num String expr = 1 + x * (3 - y) diff --git a/examples/NonEmptyList.hs b/examples/NonEmptyList.hs --- a/examples/NonEmptyList.hs +++ b/examples/NonEmptyList.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-} module NonEmptyList where import Data.Functor.Free @@ -14,7 +14,7 @@ -- So it is a non-empty list. type NonEmptyList = Free Semigroup --- These instances make NonEmptyList a Semigroup and Foldable and Traversable. +-- These instances make NonEmptyList a Semigroup and Show-able, Foldable and Traversable. deriveInstances ''Semigroup -- The next two instances make NonEmptyList a Comonad. @@ -34,5 +34,5 @@ -- Test the comonad instance, returns [10,9,7,4]. -test :: [Int] -test = toList $ extend (sum . toList) $ (pure 1 <> pure 2) <> (pure 3 <> pure 4) +test :: NonEmptyList Int +test = extend (sum . toList) $ (pure 1 <> pure 2) <> (pure 3 <> pure 4) diff --git a/free-functors.cabal b/free-functors.cabal --- a/free-functors.cabal +++ b/free-functors.cabal @@ -1,5 +1,5 @@ name: free-functors -version: 0.5 +version: 0.6 synopsis: Provides free functors that are adjoint to functors that forget class constraints. description: A free functor is a left adjoint to a forgetful functor. It used to be the case that the only category that was easy to work with in Haskell was Hask itself, so @@ -45,7 +45,7 @@ transformers >= 0.2.0.0 && < 0.4, comonad >= 3.0 && < 3.2, void >= 0.4 && < 0.7, - algebraic-classes >= 0.3.2 && < 0.4, + algebraic-classes >= 0.5 && < 0.6, template-haskell >= 2.8.0.0 && < 2.8.1 source-repository head diff --git a/src/Data/Functor/Free.hs b/src/Data/Functor/Free.hs --- a/src/Data/Functor/Free.hs +++ b/src/Data/Functor/Free.hs @@ -24,8 +24,31 @@ -- A free functor is left adjoint to a forgetful functor. -- In this package the forgetful functor forgets class constraints. ----------------------------------------------------------------------------- -module Data.Functor.Free where +module Data.Functor.Free ( + + Free(..) + , deriveInstances + , unit + , rightAdjunct + , rightAdjunctF + , rightAdjunctT + , counit + , leftAdjunct + , transform + , unfold + , convert + , convertClosed + -- * Coproducts + , Coproduct + , coproduct + , inL + , inR + , InitialObject + , initial + + ) where + import Control.Applicative import Control.Comonad import Data.Function @@ -50,28 +73,6 @@ -- Monadic bind allows you to replace each of these variables with another sub-expression. newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b } --- | Derive the instances for the class @c@ of @`Free` c a@ and @`LiftAFree` c f a@. --- --- For example: --- --- @deriveInstances ''Num@ -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` allows you to create `Free c` values, together with the operations from the class @c@. unit :: a -> Free c a unit a = Free $ \k -> k a @@ -147,21 +148,8 @@ 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) - - - --- * Coproducts - -- | 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. @@ -180,3 +168,56 @@ initial :: c r => InitialObject c -> r initial = rightAdjunct absurd + + +-- | Derive the instances of @`Free` c a@ for the class @c@, `Show`, `Foldable` and `Traversable`. +-- +-- For example: +-- +-- @deriveInstances ''Num@ +deriveInstances :: Name -> Q [Dec] +deriveInstances nm = concat <$> sequenceA + [ deriveSignature nm + , deriveInstanceWith_skipSignature freeHeader $ return [] + , deriveInstanceWith_skipSignature liftAFreeHeader $ return [] + , deriveInstanceWith_skipSignature showHelperHeader $ 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))) + 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 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) + + +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 + show = show . rightAdjunct (ShowUnit :: a -> ShowHelper (Signature c) a)