summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSjoerdVisscher <>2020-06-29 16:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-06-29 16:03:00 (GMT)
commit14dc970c80056d8814375a0c4a6ce4695fe2b97e (patch)
treeb6b215a0ce8cddce0854adfb1794e2e6e7b42f1c
parentf114b847438220f1f97025f0e8f3c0a0b3e1af99 (diff)
version 1.1.2HEAD1.1.2master
-rwxr-xr-xCHANGELOG8
-rwxr-xr-xexamples/Automaton.hs8
-rw-r--r--free-functors.cabal5
-rw-r--r--src/Data/Functor/Cofree.hs9
-rw-r--r--src/Data/Functor/Cofree/Internal.hs49
-rw-r--r--src/Data/Functor/Free/Internal.hs5
-rw-r--r--src/Data/Functor/HCofree.hs48
-rw-r--r--src/Data/Functor/HHCofree.hs41
8 files changed, 114 insertions, 59 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 3453c0f..36902be 100755
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,13 @@
CHANGELOG
+1.1.1 -> 1.1.2
+ - Update to derive-lifted-instances v0.2
+ - Add deriving instances for `Cofree`, `HCofree` and `HHCofree`
+ - Added `~=>` type, as suggested by Iceland Jack.
+
+1.1 -> 1.1.1
+ - Update to derive-lifted-instances v0.1
+
1.0.1 -> 1.1
- Use derive-lifted-instances i/o algebraic-classes
- Add deriving instances for `HFree` and `HHFree`
diff --git a/examples/Automaton.hs b/examples/Automaton.hs
index 11091d5..b8ce97d 100755
--- a/examples/Automaton.hs
+++ b/examples/Automaton.hs
@@ -1,10 +1,14 @@
{-# LANGUAGE
MultiParamTypeClasses
, FlexibleInstances
+ , TemplateHaskell
+ , RankNTypes
#-}
module Automaton where
import Data.Functor.Cofree
+import Data.Functor.Cofree.Internal
+import Data.DeriveLiftedInstances
import Control.Comonad
import Data.Functor.Identity
@@ -16,9 +20,7 @@ class Action i s where
type Automaton i = Cofree (Action i)
-
-instance Action i (Automaton i o) where
- act i (Cofree k s) = Cofree k (act i s)
+deriveInstance (cofreeDeriv 'Cofree) [t| forall a i. Action i (Automaton i a) |]
instance Action i (Identity a) where
act _ = id
diff --git a/free-functors.cabal b/free-functors.cabal
index 19ab206..0f2bc83 100644
--- a/free-functors.cabal
+++ b/free-functors.cabal
@@ -1,5 +1,5 @@
name: free-functors
-version: 1.1.1
+version: 1.1.2
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
@@ -33,6 +33,7 @@ Library
exposed-modules:
Data.Functor.Cofree,
+ Data.Functor.Cofree.Internal,
Data.Functor.Free,
Data.Functor.Free.Internal,
Data.Functor.HCofree,
@@ -48,7 +49,7 @@ Library
template-haskell >= 2.15 && < 2.17,
transformers == 0.5.*,
comonad == 5.*,
- derive-lifted-instances == 0,
+ derive-lifted-instances >= 0.2 && < 0.3,
contravariant == 1.5.*,
bifunctors == 5.*,
profunctors == 5.*
diff --git a/src/Data/Functor/Cofree.hs b/src/Data/Functor/Cofree.hs
index 2b7f69b..cb054a5 100644
--- a/src/Data/Functor/Cofree.hs
+++ b/src/Data/Functor/Cofree.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE
ConstraintKinds
, GADTs
+ , TemplateHaskell
, UndecidableInstances
, QuantifiedConstraints
#-}
@@ -24,12 +25,20 @@ import Control.Comonad
import Data.Functor.Identity
import Data.Functor.Compose
+import Language.Haskell.TH.Syntax
+import Data.Functor.Cofree.Internal
+
-- | The cofree functor for constraint @c@.
data Cofree c b where
Cofree :: c a => (a -> b) -> a -> Cofree c b
+-- | Derive the instance of @`Cofree` c a@ for the class @c@.
+deriveCofreeInstance :: Name -> Q [Dec]
+deriveCofreeInstance = deriveCofreeInstance' ''Cofree 'Cofree
+
+
counit :: Cofree c b -> b
counit (Cofree k a) = k a
diff --git a/src/Data/Functor/Cofree/Internal.hs b/src/Data/Functor/Cofree/Internal.hs
new file mode 100644
index 0000000..c1c9a28
--- /dev/null
+++ b/src/Data/Functor/Cofree/Internal.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE
+ GADTs
+ , PolyKinds
+ , RankNTypes
+ , ViewPatterns
+ , TypeOperators
+ , DeriveFunctor
+ , DeriveFoldable
+ , ConstraintKinds
+ , TemplateHaskell
+ , DeriveTraversable
+ , FlexibleInstances
+ , ScopedTypeVariables
+ , UndecidableInstances
+ , QuantifiedConstraints
+ , MultiParamTypeClasses
+ , UndecidableSuperClasses
+ #-}
+module Data.Functor.Cofree.Internal where
+
+import Data.Monoid (Ap(..))
+
+import Language.Haskell.TH.Syntax
+import Data.DeriveLiftedInstances
+
+
+kExp :: Q Exp
+kExp = pure . VarE $ mkName "k"
+
+kPat :: Pat
+kPat = VarP $ mkName "k"
+
+cofreeDeriv :: Name -> Derivator
+cofreeDeriv cofree = idDeriv {
+ cst = \e -> [| const $e $kExp |], -- Suppress "Defined but not used: ‘k’" warning
+ res = \e -> [| $(pure (ConE cofree)) $kExp $e |],
+ eff = \e -> [| $(pure (ConE cofree)) $kExp <$> $e |],
+ inp = fmap (\vp -> ConP cofree [kPat, vp])
+}
+
+deriveCofreeInstance' :: Name -> Name -> Name -> Q [Dec]
+deriveCofreeInstance' (pure . ConT -> cofree) ccofree (pure . ConT -> clss)
+ = deriveInstance (cofreeDeriv ccofree)
+ [t| forall a c. (c ~=> $clss) => $clss ($cofree c a) |]
+
+class (a => b) => a :=> b
+instance (a => b) => a :=> b
+
+type a ~=> b = forall x. a x :=> b x
diff --git a/src/Data/Functor/Free/Internal.hs b/src/Data/Functor/Free/Internal.hs
index 78f72b1..ef1f239 100644
--- a/src/Data/Functor/Free/Internal.hs
+++ b/src/Data/Functor/Free/Internal.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE
GADTs
+ , PolyKinds
, RankNTypes
, ViewPatterns
, TypeOperators
@@ -39,7 +40,7 @@ deriveFreeInstance' :: Name -> Name -> Name -> Name -> Q [Dec]
deriveFreeInstance' (pure . ConT -> free) cfree runFree (pure . ConT -> clss)
= deriveInstance
(freeDeriv cfree runFree)
- [t| forall a c. (forall x. c x :=> $clss x) => $clss ($free c a) |]
+ [t| forall a c. (c ~=> $clss) => $clss ($free c a) |]
deriveInstances' :: Name -> Name -> Name -> Name -> Q [Dec]
deriveInstances' tfree cfree runFree nm@(pure . ConT -> clss) =
@@ -51,3 +52,5 @@ deriveInstances' tfree cfree runFree nm@(pure . ConT -> clss) =
class (a => b) => a :=> b
instance (a => b) => a :=> b
+
+type a ~=> b = forall x. a x :=> b x
diff --git a/src/Data/Functor/HCofree.hs b/src/Data/Functor/HCofree.hs
index 9554b02..044de7a 100644
--- a/src/Data/Functor/HCofree.hs
+++ b/src/Data/Functor/HCofree.hs
@@ -3,6 +3,7 @@
, RankNTypes
, TypeOperators
, ConstraintKinds
+ , TemplateHaskell
, UndecidableInstances
, QuantifiedConstraints
#-}
@@ -26,9 +27,12 @@ module Data.Functor.HCofree where
import Control.Comonad
import Control.Comonad.Trans.Class
-import Data.Foldable
import Data.Functor.Identity
+import Language.Haskell.TH.Syntax
+import Data.Functor.Cofree.Internal
+
+
-- | Natural transformations.
type f :~> g = forall b. f b -> g b
@@ -37,6 +41,15 @@ data HCofree c g a where
HCofree :: c f => (f :~> g) -> f a -> HCofree c g a
+-- | Derive the instance of @`HCofree` c a@ for the class @c@.
+--
+-- For example:
+--
+-- @deriveHCofreeInstance ''Traversable@
+deriveHCofreeInstance :: Name -> Q [Dec]
+deriveHCofreeInstance = deriveCofreeInstance' ''HCofree 'HCofree
+
+
counit :: HCofree c g :~> g
counit (HCofree k fa) = k fa
@@ -75,37 +88,12 @@ coiter f = leftAdjunct (f . runIdentity) . Identity
unwrap :: HCofree Comonad g a -> g (HCofree Comonad g a)
unwrap = counit . duplicate
-instance (forall x. c x => Functor x) => Functor (HCofree c g) where
- fmap f (HCofree k a) = HCofree k (fmap f a)
- a <$ HCofree k b = HCofree k (a <$ b)
-
-instance (forall x. c x => Foldable x) => Foldable (HCofree c g) where
- foldMap f (HCofree _ a) = foldMap f a
- foldMap' f (HCofree _ a) = foldMap' f a
- fold (HCofree _ a) = fold a
- foldr f z (HCofree _ a) = foldr f z a
- foldl f z (HCofree _ a) = foldl f z a
- foldl' f z (HCofree _ a) = foldl' f z a
- foldr1 f (HCofree _ a) = foldr1 f a
- foldr' f z (HCofree _ a) = foldr' f z a
- foldl1 f (HCofree _ a) = foldl1 f a
- toList (HCofree _ a) = toList a
- null (HCofree _ a) = null a
- length (HCofree _ a) = length a
- elem e (HCofree _ a) = elem e a
- maximum (HCofree _ a) = maximum a
- minimum (HCofree _ a) = minimum a
- sum (HCofree _ a) = sum a
- product (HCofree _ a) = product a
-
-instance (forall x. c x => Traversable x) => Traversable (HCofree c g) where
- traverse f (HCofree k a) = HCofree k <$> traverse f a
- sequenceA (HCofree k a) = HCofree k <$> sequenceA a
- mapM f (HCofree k a) = HCofree k <$> mapM f a
- sequence (HCofree k a) = HCofree k <$> sequence a
+deriveCofreeInstance' ''HCofree 'HCofree ''Functor
+deriveCofreeInstance' ''HCofree 'HCofree ''Foldable
+deriveCofreeInstance' ''HCofree 'HCofree ''Traversable
-- | The cofree comonad of a functor.
-instance (forall x. c x => Comonad x) => Comonad (HCofree c g) where
+instance (c ~=> Comonad) => Comonad (HCofree c g) where
extract (HCofree _ a) = extract a
extend f (HCofree k a) = HCofree k $ extend (f . HCofree k) a
duplicate (HCofree k a) = HCofree k $ extend (HCofree k) a
diff --git a/src/Data/Functor/HHCofree.hs b/src/Data/Functor/HHCofree.hs
index 9d8ed4b..b18bfc8 100644
--- a/src/Data/Functor/HHCofree.hs
+++ b/src/Data/Functor/HHCofree.hs
@@ -2,6 +2,7 @@
GADTs
, RankNTypes
, TypeOperators
+ , TemplateHaskell
, ConstraintKinds
, FlexibleContexts
, FlexibleInstances
@@ -32,9 +33,11 @@ import Control.Category
import Data.Bifunctor
import Data.Bifunctor.Functor
import Data.Profunctor
-import Data.Profunctor.Unsafe
import Data.Profunctor.Monad
+import Language.Haskell.TH.Syntax
+import Data.Functor.Cofree.Internal
+
-- | Natural transformations.
type f :~~> g = forall c d. f c d -> g c d
@@ -44,6 +47,15 @@ data HHCofree c g a b where
HHCofree :: c f => (f :~~> g) -> f a b -> HHCofree c g a b
+-- | Derive the instance of @`HHCofree` c a@ for the class @c@.
+--
+-- For example:
+--
+-- @deriveHHCofreeInstance ''Profunctor@
+deriveHHCofreeInstance :: Name -> Q [Dec]
+deriveHHCofreeInstance = deriveCofreeInstance' ''HHCofree 'HHCofree
+
+
counit :: HHCofree c g :~~> g
counit (HHCofree k fa) = k fa
@@ -83,25 +95,8 @@ instance ProfunctorComonad (HHCofree c) where
produplicate = hextend id
-instance (forall x. c x => Bifunctor x) => Bifunctor (HHCofree c g) where
- bimap f g (HHCofree k a) = HHCofree k (bimap f g a)
- first f (HHCofree k a) = HHCofree k (first f a)
- second f (HHCofree k a) = HHCofree k (second f a)
-
-instance (forall x. c x => Profunctor x) => Profunctor (HHCofree c g) where
- dimap f g (HHCofree k a) = HHCofree k (dimap f g a)
- lmap f (HHCofree k a) = HHCofree k (lmap f a)
- rmap f (HHCofree k a) = HHCofree k (rmap f a)
- f #. HHCofree k g = HHCofree k (f #. g)
- HHCofree k g .# f = HHCofree k (g .# f)
-
-instance (forall x. c x => Strong x) => Strong (HHCofree c f) where
- first' (HHCofree k a) = HHCofree k (first' a)
- second' (HHCofree k a) = HHCofree k (second' a)
-
-instance (forall x. c x => Choice x) => Choice (HHCofree c f) where
- left' (HHCofree k a) = HHCofree k (left' a)
- right' (HHCofree k a) = HHCofree k (right' a)
-
-instance (forall x. c x => Closed x) => Closed (HHCofree c f) where
- closed (HHCofree k a) = HHCofree k (closed a)
+deriveCofreeInstance' ''HHCofree 'HHCofree ''Bifunctor
+deriveCofreeInstance' ''HHCofree 'HHCofree ''Profunctor
+deriveCofreeInstance' ''HHCofree 'HHCofree ''Strong
+deriveCofreeInstance' ''HHCofree 'HHCofree ''Choice
+deriveCofreeInstance' ''HHCofree 'HHCofree ''Closed