free-functors 0.8 → 0.8.1

raw patch · 8 files changed

+240/−35 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +4/−0
• examples/FreeNum.hs +2/−1
• examples/NonEmptyList.hs +2/−1
• free-functors.cabal +3/−1
• src/Data/Constraint/Class1.hs +39/−0
• src/Data/Functor/Free.hs +25/−32
• src/Data/Functor/Free/TH.hs +49/−0
• src/Data/Functor/HHCofree.hs +116/−0

@@ -1,5 +1,9 @@ CHANGELOG +0.8 -> 0.8.1+  - Added HHCofree+  - Changes towards support for `SuperClass1` in TH code for `Free`+   0.7.2 -> 0.8   - Updated for GHC 8.2     - Updated to base-4.10

@@ -3,7 +3,8 @@  import Data.Functor.Free -deriveInstances ''Num+-- This is what you would normally do with your own class, for Num this is already done for you.+-- deriveInstances ''Num   x, y :: Free Num String

@@ -12,7 +12,8 @@ type NonEmptyList = Free Semigroup  -- These instances make NonEmptyList a Semigroup and Show-able, Foldable and Traversable.-deriveInstances ''Semigroup+-- This is what you would normally do with your own class, for Semigroup this is already done for you.+-- deriveInstances ''Semigroup  -- The next two instances make NonEmptyList a Comonad. instance Semigroup (Extract a) where

@@ -1,5 +1,5 @@ name:                free-functors-version:             0.8+version:             0.8.1 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@@ -35,8 +35,10 @@     Data.Constraint.Class1,     Data.Functor.Cofree,     Data.Functor.Free,+    Data.Functor.Free.TH,     Data.Functor.HCofree,     Data.Functor.HFree,+    Data.Functor.HHCofree,     Data.Functor.HHFree    default-language:

@@ -35,6 +35,7 @@ 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@@ -51,6 +52,44 @@   containsSelf :: FoldConstraints (SuperClasses c) x :- c x   default containsSelf :: (SuperClasses c ~ '[c]) => FoldConstraints (SuperClasses c) x :- c x   containsSelf = Sub Dict+++instance HasSuperClasses Num+instance HasSuperClasses Eq+instance HasSuperClasses Enum+instance HasSuperClasses Bounded+instance HasSuperClasses Show+instance HasSuperClasses Read+instance HasSuperClasses Ord where+  type SuperClasses Ord = Ord ': SuperClasses Eq+  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses Real where+  type SuperClasses Real = Real ': SuperClasses Num ++ SuperClasses Ord+  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses Fractional where+  type SuperClasses Fractional = Fractional ': SuperClasses Num+  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses Integral where+  type SuperClasses Integral = Integral ': SuperClasses Real ++ SuperClasses Enum +  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses RealFrac where+  type SuperClasses RealFrac = RealFrac ': SuperClasses Real ++ SuperClasses Fractional +  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses Floating where+  type SuperClasses Floating = Floating ': SuperClasses Fractional +  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses RealFloat where+  type SuperClasses RealFloat = RealFloat ': SuperClasses RealFrac ++ SuperClasses Floating +  superClasses = Sub Dict+  containsSelf = Sub Dict+instance HasSuperClasses Semigroup+instance HasSuperClasses Monoid  instance HasSuperClasses Functor instance HasSuperClasses Applicative where

@@ -12,6 +12,7 @@   , DeriveTraversable   , TemplateHaskell   , PolyKinds+  , TypeFamilies   #-} ----------------------------------------------------------------------------- -- |@@ -53,18 +54,22 @@  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 Data.Algebra.TH 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@@@ -148,8 +153,12 @@   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)+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+         @@ -173,38 +182,10 @@ 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 []-  , [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+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@@ -225,3 +206,15 @@  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' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper++deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Num+deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Semigroup+deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Monoid

@@ -0,0 +1,49 @@+{-# LANGUAGE+    ConstraintKinds+  , GADTs+  , RankNTypes+  , TypeOperators+  , FlexibleInstances+  , MultiParamTypeClasses+  , UndecidableInstances+  , ScopedTypeVariables+  , DeriveFunctor+  , DeriveFoldable+  , DeriveTraversable+  , TemplateHaskell+  , PolyKinds+  #-}+module Data.Functor.Free.TH where++import Data.Constraint hiding (Class)+import Data.Constraint.Class1++import Data.Algebra.TH+import Language.Haskell.TH.Syntax++deriveInstances' :: Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]+deriveInstances' forallLiftedNm dictLiftedNm freeNm liftAFreeNm showHelperNm nm = concat <$> sequenceA+  [ deriveSignature nm+  , deriveInstanceWith_skipSignature freeHeader $ return []+  , deriveInstanceWith_skipSignature liftAFreeHeader $ return []+  , deriveInstanceWith_skipSignature showHelperHeader $ return []+  , return $ [InstanceD Nothing [] (AppT (ConT forallLiftedNm) c) [ValD (VarP dictLiftedNm) (NormalB (ConE '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)))+    isSC = AppT (AppT superClass1 c) (VarT vc)+    free = ConT freeNm+    liftAFree = ConT liftAFreeNm+    showHelper = ConT showHelperNm+    superClass1 = ConT ''SuperClass1+    c = ConT nm+    sig = ConT $ mkName (nameBase nm ++ "Signature")+    a = mkName "a"+    f = mkName "f"+    vc = mkName "c"+

@@ -0,0 +1,116 @@+{-# LANGUAGE+    GADTs+  , RankNTypes+  , TypeOperators+  , ConstraintKinds+  , FlexibleContexts+  , FlexibleInstances+  , ScopedTypeVariables+  , UndecidableInstances+  , MultiParamTypeClasses+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.HHCofree+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  sjoerd@w3future.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- A cofree functor is right adjoint to a forgetful functor.+-- In this package the forgetful functor forgets class constraints.+--+-- Compared to @Data.Functor.HCofree@ we have 2 two parameters.+-----------------------------------------------------------------------------+module Data.Functor.HHCofree where++import Prelude hiding ((.), id)+import Data.Constraint (Dict(..), (:-)(..))+import Data.Constraint.Class1+import Data.Functor.HHFree (HHFree(..))+import qualified Data.Functor.HHFree as F++import Control.Category+import Data.Bifunctor (Bifunctor(bimap))+import Data.Bifunctor.Functor+import Data.Profunctor+import Data.Profunctor.Monad+++-- | Natural transformations.+type f :~~> g = forall c d. f c d -> g c d++-- | The higher order cofree functor for constraint @c@.+data HHCofree c g a b where+  HHCofree :: c f => (f :~~> g) -> f a b -> HHCofree c g a b+++counit :: HHCofree c g :~~> g+counit (HHCofree k fa) = k fa++leftAdjunct :: c f => (f :~~> g) -> f :~~> HHCofree c g+leftAdjunct k fa = HHCofree k fa++-- | @unit = leftAdjunct id@+unit :: c g => g :~~> HHCofree c g+unit = leftAdjunct id++-- | @rightAdjunct f = counit . f@+rightAdjunct :: (f :~~> HHCofree c g) -> f :~~> g+rightAdjunct f = counit . f++transform :: (forall r. c r => (r :~~> f) -> r :~~> g) -> HHCofree c f :~~> HHCofree c g+transform t (HHCofree k a) = HHCofree (t k) a++hfmap :: (f :~~> g) -> HHCofree c f :~~> HHCofree c g+hfmap f = transform (\k -> f . k)++hextend :: (HHCofree c f :~~> g) -> HHCofree c f :~~> HHCofree c g+hextend f = transform (\k -> f . leftAdjunct k)+++instance BifunctorFunctor (HHCofree c) where+  bifmap = hfmap++instance BifunctorComonad (HHCofree c) where+  biextract = counit+  biextend = hextend+  +instance ProfunctorFunctor (HHCofree c) where+  promap = hfmap++instance ProfunctorComonad (HHCofree c) where+  proextract = counit+  produplicate = hextend id+++instance SuperClass1 Bifunctor c => Bifunctor (HHCofree c g) where+  bimap f g (HHCofree k a) = HHCofree k (h scls1 f g a)+    where+      h :: c f => (c f :- Bifunctor f) -> (a -> a') -> (b -> b') -> f a b -> f a' b'+      h (Sub Dict) = bimap+      +instance SuperClass1 Profunctor c => Profunctor (HHCofree c g) where+  dimap f g (HHCofree k a) = HHCofree k (h scls1 f g a)+    where+      h :: c f => (c f :- Profunctor f) -> (a' -> a) -> (b -> b') -> f a b -> f a' b'+      h (Sub Dict) = dimap+      +instance SuperClass1 Strong c => Strong (HHCofree c f) where+  first' (HHCofree k a) = HHCofree k (h scls1 a)+    where+      h :: c g => (c g :- Strong g) -> g a b -> g (a, d) (b, d)+      h (Sub Dict) = first'+      +instance SuperClass1 Choice c => Choice (HHCofree c f) where+  left' (HHCofree k a) = HHCofree k (h scls1 a)+    where+      h :: c g => (c g :- Choice g) -> g a b -> g (Either a d) (Either b d)+      h (Sub Dict) = left'+      +instance SuperClass1 Closed c => Closed (HHCofree c f) where+  closed (HHCofree k a) = HHCofree k (h scls1 a)+    where+      h :: c g => (c g :- Closed g) -> g a b -> g (d -> a) (d -> b)+      h (Sub Dict) = closed