free-functors 0.5 → 0.6

raw patch · 4 files changed

+85/−44 lines, 4 filesdep ~algebraic-classesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: algebraic-classes

API changes (from Hackage documentation)

Files

• examples/FreeNum.hs +2/−2
• examples/NonEmptyList.hs +4/−4
• free-functors.cabal +2/−2
• src/Data/Functor/Free.hs +77/−36

@@ -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) 

@@ -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)

@@ -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

@@ -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)