free-functors 0.2 → 0.3

raw patch · 4 files changed

+53/−20 lines, 4 filesdep +algebraic-classesPVP ok

version bump matches the API change (PVP)

Dependencies added: algebraic-classes

API changes (from Hackage documentation)

Files

• examples/FreeNum.hs +4/−10
• examples/NonEmptyList.hs +9/−7
• free-functors.cabal +3/−2
• src/Data/Functor/Free.hs +37/−1

@@ -1,18 +1,12 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module FreeNum where  import Data.Functor.Free+import Data.Algebra -import Control.Applicative -instance Num (Free Num a) where-  Free l + Free r = Free $ (+) <$> l <*> r-  Free l * Free r = Free $ (*) <$> l <*> r-  Free l - Free r = Free $ (-) <$> l <*> r-  negate (Free f) = Free $ negate <$> f-  abs (Free f)    = Free $ abs <$> f-  signum (Free f) = Free $ signum <$> f-  fromInteger i   = Free $ pure (fromInteger i)+deriveInstance [t| () => Num (Free Num a) |]+  x, y :: Free Num String x = return "x"

@@ -1,26 +1,28 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module NonEmptyList where  import Data.Functor.Free--import Data.Semigroup+import Data.Algebra  import Control.Applicative import Control.Comonad import Data.Functor.Identity import Data.Functor.Compose +class Semigroup s where+  (<>) :: s -> s -> s +instance Semigroup [a] where+  (<>) = (++)+   -- This declaration creates a Functor that is also Applicative. type NonEmptyList = Free Semigroup  -- This instance makes NonEmptyList a Monad.-instance Semigroup (NonEmptyList a) where-  Free fa <> Free fb = Free $ liftA2 (<>) fa fb+deriveInstance [t| () => Semigroup (NonEmptyList a) |]  -- This instance makes NonEmptyList Foldable and Traversable.-instance Applicative f => Semigroup (LiftAFree Semigroup f a) where-  LiftAFree fa <> LiftAFree fb = LiftAFree $ liftA2 (<>) fa fb+deriveInstance [t| Applicative f => Semigroup (LiftAFree Semigroup f a) |]  -- The next two instances make NonEmptyList a Comonad. instance Semigroup (Identity a) where

@@ -1,5 +1,5 @@ name:                free-functors-version:             0.2+version:             0.3 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@@ -44,7 +44,8 @@     constraints >= 0.3.2 && < 0.4,     transformers >= 0.2.0.0 && < 0.4,     comonad >= 3.0 && < 3.1,-    void >= 0.4 && < 0.7+    void >= 0.4 && < 0.7,+    algebraic-classes == 0.1.*  source-repository head   type:     git

@@ -1,11 +1,15 @@ {-# LANGUAGE     ConstraintKinds+  , GADTs   , RankNTypes   , TypeOperators     , FlexibleInstances   , MultiParamTypeClasses   , UndecidableInstances   , ScopedTypeVariables+  , DeriveFunctor+  , DeriveFoldable+  , DeriveTraversable   #-} ----------------------------------------------------------------------------- -- |@@ -24,7 +28,7 @@ import Control.Applicative import Control.Comonad -import Data.Constraint+import Data.Constraint hiding (Class) import Data.Constraint.Forall  import Data.Functor.Identity@@ -33,6 +37,7 @@ import Data.Traversable import Data.Void +import Data.Algebra  -- | The free functor for constraint @c@. newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }@@ -85,8 +90,14 @@   extract = runIdentity . rightAdjunctF Identity   extend g = fmap g . getCompose . rightAdjunctF (Compose . return . return) +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 @@ -98,3 +109,28 @@  convertClosed :: c r => Free c Void -> r convertClosed = rightAdjunct absurd++type InitialObject c = Free c Void++initial :: c r => InitialObject c -> r+initial = rightAdjunct absurd++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 :: c m => m -> Coproduct c m n+inL = unit . Left++inR :: c n => n -> Coproduct c m n+inR = unit . Right++product :: (r -> m) -> (r -> n) -> r -> Free c (m, n)+product m n r = unit (m r, n r)++fstP :: c m => Free c (m, n) -> m+fstP = rightAdjunct fst++sndP :: c n => Free c (m, n) -> n+sndP = rightAdjunct snd