packages feed

free-functors 0.8.3 → 0.8.4

raw patch · 5 files changed

+138/−145 lines, 5 filesdep ~algebraic-classesdep ~basedep ~constraints

Dependency ranges changed: algebraic-classes, base, constraints, contravariant, template-haskell

Files

CHANGELOG view
@@ -1,5 +1,12 @@ CHANGELOG +0.8.3 -> 0.8.4+  - Updated to constraints-0.10+  - Updated for GHC 8.4+    - Updated to base-4.11+    - Updated to template-haskell-2.13+    - `Semigroup` is now a superclass of `Monoid`+ 0.8.2 -> 0.8.3   - Added Data.Functor.Free.TH to other-modules
free-functors.cabal view
@@ -1,5 +1,5 @@ name:                free-functors-version:             0.8.3+version:             0.8.4 synopsis:            Free functors, 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@@ -47,12 +47,12 @@     Haskell2010    build-depends:-    base >= 4.9 && < 4.11,-    template-haskell >= 2.11 && < 2.13,-    constraints == 0.9.*,+    base == 4.11.*,+    template-haskell == 2.13.*,+    constraints == 0.10.*,     transformers == 0.5.*,     comonad == 5.*,-    algebraic-classes >= 0.9 && < 1.0,+    algebraic-classes == 0.9.*,     contravariant == 1.4.*,     bifunctors == 5.*,     profunctors == 5.*
src/Data/Constraint/Class1.hs view
@@ -35,7 +35,6 @@ import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import Data.Profunctor-import Data.Semigroup  -- | Proof that @b@ is a superclass of @h@, i.e. @h x@ entails @b x@. scls1 :: forall b h x. SuperClass1 b h => h x :- b x@@ -89,7 +88,10 @@   superClasses = Sub Dict   containsSelf = Sub Dict instance HasSuperClasses Semigroup-instance HasSuperClasses Monoid+instance HasSuperClasses Monoid where+  type SuperClasses Monoid = Monoid ': SuperClasses Semigroup+  superClasses = Sub Dict+  containsSelf = Sub Dict  instance HasSuperClasses Functor instance HasSuperClasses Applicative where
src/Data/Functor/Free.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE     ConstraintKinds   , GADTs@@ -56,73 +57,14 @@    ) where -import Control.Comonad import Data.Function-import Data.Semigroup -import Data.Constraint hiding (Class)-import Data.Constraint.Forall-import Data.Constraint.Class1--import Data.Foldable (Foldable(..))-import Data.Traversable import Data.Void -import Data.Algebra import Language.Haskell.TH.Syntax  import Data.Functor.Free.TH ---- | The free functor for class @c@.------   @Free c a@ is basically an expression tree with operations from class @c@---   and variables/placeholders of type @a@, created with `unit`.---   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 }---- | `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---- | `rightAdjunct` is the destructor of @`Free` c@ values.-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 = rightAdjunct id@-counit :: c a => Free c a -> a-counit = rightAdjunct id---- | @leftAdjunct f = f . unit@-leftAdjunct :: (Free c a -> b) -> a -> b-leftAdjunct f = f . unit---- | @transform f as = as >>= f unit@------ @transform f . transform g = transform (g . f)@-transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b-transform t (Free f) = Free (f . t)- -- | @unfold f = coproduct (unfold f) unit . f@ -- -- `inL` and `inR` are useful here. For example, the following creates the list @[1..10]@ as a @Free Monoid@:@@ -139,33 +81,7 @@ 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 SuperClass1 (Class f) c => Algebra f (Free c a) where-  algebra fa = Free $ \k -> h scls1 (fmap (rightAdjunct k) fa)-    where-      h :: c b => (c b :- Class f b) -> f b -> b-      h (Sub Dict) = evaluate-      --- -- | 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.@@ -186,41 +102,16 @@ initial = rightAdjunct absurd  --newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }--instance (Applicative f, SuperClass1 (Class s) c) => 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)-   -- | Derive the instances of @`Free` c a@ for the class @c@, `Show`, `Foldable` and `Traversable`. -- -- For example: -- -- @deriveInstances ''Num@ deriveInstances :: Name -> Q [Dec]-deriveInstances = deriveInstances' True ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper+deriveInstances = deriveInstances' True -deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Num-deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Fractional-deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Floating-deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Semigroup-deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Monoid+deriveInstances' False ''Num+deriveInstances' False ''Fractional+deriveInstances' False ''Floating+deriveInstances' False ''Semigroup+deriveInstances' False ''Monoid
src/Data/Functor/Free/TH.hs view
@@ -18,12 +18,116 @@  import Data.Constraint hiding (Class) import Data.Constraint.Class1+import Data.Constraint.Forall +import Control.Comonad+import Data.Algebra import Data.Algebra.TH import Language.Haskell.TH.Syntax+import Data.Traversable -deriveInstances' :: Bool -> Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]-deriveInstances' withHSC forallLiftedNm dictLiftedNm freeNm liftAFreeNm showHelperNm nm = getSignatureInfo nm >>= h where+-- | The free functor for class @c@.+--+--   @Free c a@ is basically an expression tree with operations from class @c@+--   and variables/placeholders of type @a@, created with `unit`.+--   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 }++-- | `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++-- | `rightAdjunct` is the destructor of @`Free` c@ values.+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++-- | @counit = rightAdjunct id@+counit :: c a => Free c a -> a+counit = rightAdjunct id++-- | @leftAdjunct f = f . unit@+leftAdjunct :: (Free c a -> b) -> a -> b+leftAdjunct f = f . unit++-- | @transform f as = as >>= f unit@+--+-- @transform f . transform g = transform (g . f)@+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 (ForallF c Extract, ForallF c (Duplicate (Free c)))+  => Comonad (Free c) where+  extract = getExtract . rightAdjunctF Extract+  duplicate = getDuplicate . rightAdjunctF (Duplicate . unit . unit)+      ++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++newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }++instance SuperClass1 (Class f) c => Algebra f (Free c a) where+  algebra fa = Free $ \k -> h scls1 (fmap (rightAdjunct k) fa)+    where+      h :: c b => (c b :- Class f b) -> f b -> b+      h (Sub Dict) = evaluate+      +instance (Applicative f, SuperClass1 (Class s) c) => 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)+++deriveInstances' :: Bool -> Name -> Q [Dec]+deriveInstances' withHSC nm = getSignatureInfo nm >>= h where   h sigInfo =     concat <$> sequenceA     [ deriveSignature nm@@ -32,28 +136,17 @@     , deriveInstanceWith_skipSignature showHelperHeader $ return []     , deriveSuperclassInstances showHelperHeader     , hasSuperClassesInstance-    , return $ [InstanceD Nothing [] (AppT (ConT forallLiftedNm) c) [ValD (VarP dictLiftedNm) (NormalB (ConE 'Dict)) []]]+    , [d|instance ForallLifted $c where dictLifted = Dict|]     ]     where-      freeHeader = return $ ForallT [PlainTV a, PlainTV vc] [AppT (AppT superClass1 c) (VarT vc)]-        (AppT c (AppT (AppT free (VarT vc)) (VarT a)))-      liftAFreeHeader = return $ ForallT [PlainTV f, PlainTV a, PlainTV vc] [AppT (ConT ''Applicative) (VarT f), isSC]-        (AppT c (AppT (AppT (AppT liftAFree (VarT vc)) (VarT f)) (VarT a)))-      showHelperHeader = return $ ForallT [PlainTV a] []-        (AppT c (AppT (AppT showHelper sig) (VarT a)))-      hasSuperClassesInstance = if withHSC then [d|instance HasSuperClasses $(pure c) where {-        type SuperClasses $(pure c) = $(pure c) ': $(scs);+      freeHeader = [t|forall a vc. SuperClass1 $c vc => $c (Free vc a)|]+      liftAFreeHeader = [t|forall f a vc. (Applicative f, SuperClass1 $c vc) => $c (LiftAFree vc f a)|]+      showHelperHeader = [t|forall a. $c (ShowHelper $sig a)|]+      hasSuperClassesInstance = if withHSC then [d|instance HasSuperClasses $c where {+        type SuperClasses $c = $c ': $scs;         superClasses = Sub Dict;         containsSelf = Sub Dict       }|] else return []-      scs = foldr (\(SuperclassTH scnm _ _) q -> [t|SuperClasses $(pure (ConT scnm)) ++ $(q)|]) [t|'[]|] $ superclasses sigInfo-      isSC = AppT (AppT superClass1 c) (VarT vc)-      free = ConT freeNm-      liftAFree = ConT liftAFreeNm-      showHelper = ConT showHelperNm-      superClass1 = ConT ''SuperClass1-      c = ConT nm-      sig = ConT $ signatureName sigInfo-      a = mkName "a"-      f = mkName "f"-      vc = mkName "c"+      scs = foldr (\(SuperclassTH scnm _ _) q -> [t|SuperClasses $(pure (ConT scnm)) ++ $q|]) [t|'[]|] $ superclasses sigInfo+      c = pure $ ConT nm+      sig = pure . ConT $ signatureName sigInfo