packages feed

free-functors 1.0.1 → 1.1

raw patch · 13 files changed

+245/−234 lines, 13 filesdep +derive-lifted-instancesdep −algebraic-classesdep ~basedep ~template-haskell

Dependencies added: derive-lifted-instances

Dependencies removed: algebraic-classes

Dependency ranges changed: base, template-haskell

Files

CHANGELOG view
@@ -1,5 +1,17 @@ CHANGELOG +1.0.1 -> 1.1+  - Use derive-lifted-instances i/o algebraic-classes+  - Add deriving instances for `HFree` and `HHFree`+  - Fix `Traversable` and `Foldable` instances of `Free`++1.0 -> 1.0.1+  - Simpler `ShowHelper`++0.8.4 -> 1.0+  - Switch to using the QuantifiedConstraints extension+  - Removed Data.Constraint.Class1+ 0.8.3 -> 0.8.4   - Updated to constraints-0.10   - Updated for GHC 8.4@@ -9,16 +21,16 @@  0.8.2 -> 0.8.3   - Added Data.Functor.Free.TH to other-modules-  + 0.8.1 -> 0.8.2   - Support for `deriveInstances` for classes which have one or more superclasses   - `deriveInstances` now also derives the `HasSuperClasses` instance   - Expose internal `ShowHelper` datatype-  + 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
examples/FreeNum.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, LambdaCase #-} module FreeNum where  import Data.Functor.Free@@ -17,7 +17,7 @@  -- Monadic bind is variable substitution subst :: Free Num String -> Free Num a-subst e = e >>= \v -> case v of +subst e = e >>= \case   "x" -> 10   _   -> 2
examples/NonEmptyList.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} module NonEmptyList where  import Data.Functor.Free@@ -25,4 +25,4 @@  -- Test the comonad and foldable instances, returns [15,14,12,9,5]. test :: NonEmptyList Int-test = extend sum $ (pure 1 <> pure 2) <> (pure 3 <> (pure 4 <> pure 5))+test = extend sum $ ((pure 1 <> pure 2) <> pure 3 <> pure 4) <> pure 5
+ examples/Sem.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, QuantifiedConstraints, FlexibleInstances #-}+module Sem where+  +import Data.Functor.Free++class BaseSem a where+  val :: Int -> a+  add :: a -> a -> a++instance BaseSem Int where+  val = id+  add = (+)++class BaseSem a => AdvSem a where+  mul :: a -> a -> a++instance AdvSem Int where+  mul = (*)++deriveInstances ''BaseSem+deriveInstances ''AdvSem+++test :: Free AdvSem String+test = mul (add (pure "a") (val 3)) (val 5)++evaluate :: Free AdvSem String -> Int+evaluate = rightAdjunct lookupVar+  where+    lookupVar :: String -> Int+    lookupVar "a" = 2+    lookupVar v = error $ "Unknown variable: " ++ v++main :: IO ()+main = putStrLn $ show test ++ " = " ++ show (evaluate test)++vars :: Free AdvSem a -> [a]+vars = foldMap pure
examples/SemSum.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE -  TemplateHaskell, TypeFamilies, DeriveTraversable, FlexibleInstances, UndecidableInstances,+  TemplateHaskell, FlexibleInstances, UndecidableInstances,    TypeOperators, MultiParamTypeClasses, ConstraintKinds, UndecidableSuperClasses, QuantifiedConstraints    #-}    module Sem where   -import GHC.Generics-import Data.Algebra import Data.Functor.Free  class BaseSem a where@@ -32,13 +30,6 @@  class (a x, b x) => (a + b) x instance (a x, b x) => (a + b) x--type instance Signature (a + b) = Signature a :+: Signature b--instance (AlgebraSignature f, AlgebraSignature g) => AlgebraSignature (f :+: g) where-  type Class (f :+: g) = Class f + Class g-  evaluate (L1 f) = evaluate f-  evaluate (R1 f) = evaluate f     deriveInstances ''BaseSem
free-functors.cabal view
@@ -1,5 +1,5 @@ name:                free-functors-version:             1.0.1+version:             1.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@@ -44,11 +44,11 @@     Haskell2010    build-depends:-    base == 4.12.*,-    template-haskell == 2.14.*,+    base >= 4.13 && < 4.15,+    template-haskell >= 2.15 && < 2.17,     transformers == 0.5.*,     comonad == 5.*,-    algebraic-classes == 0.9.*,+    derive-lifted-instances == 0,     contravariant == 1.5.*,     bifunctors == 5.*,     profunctors == 5.*
src/Data/Functor/Cofree.hs view
@@ -34,7 +34,7 @@ counit (Cofree k a) = k a  leftAdjunct :: c a => (a -> b) -> a -> Cofree c b-leftAdjunct f a = Cofree f a+leftAdjunct = Cofree  -- | @unit = leftAdjunct id@ unit :: c b => b -> Cofree c b
src/Data/Functor/Free.hs view
@@ -1,6 +1,7 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-} {-# LANGUAGE-    TypeFamilies+    RankNTypes+  , TypeFamilies   , TypeOperators   , DeriveFunctor   , DeriveFoldable@@ -27,6 +28,7 @@ module Data.Functor.Free (      Free(..)+  , deriveFreeInstance   , deriveInstances   , unit   , rightAdjunct@@ -46,18 +48,79 @@   , inR   , InitialObject   , initial-  -  -- * Internal-  , ShowHelper(..)    ) where -import Data.Function-+import Data.Function (fix)+import Data.Monoid (Ap(..)) import Data.Void+import Data.Traversable+import Control.Comonad +import Language.Haskell.TH.Syntax import Data.Functor.Free.Internal+import Data.DeriveLiftedInstances (ShowsPrec(..), deriveInstance, apDeriv, idDeriv) ++-- | 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++-- | @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++instance (forall f x. Applicative f => c (Ap f (Free c x))) => Foldable (Free c) where+  foldMap = foldMapDefault++instance (forall f x. Applicative f => c (Ap f (Free c x))) => Traversable (Free c) where+  traverse f = getAp . rightAdjunct (Ap . fmap unit . f)++instance (Show a, c ShowsPrec) => Show (Free c a) where+  showsPrec p = showsPrec p . rightAdjunct (\a -> ShowsPrec $ \d -> showParen (d > 10) $ showString "pure " . showsPrec 11 a)+++newtype Extract a = Extract { getExtract :: a }+newtype Duplicate f a = Duplicate { getDuplicate :: f (f a) }+instance (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))+  => Comonad (Free c) where+  extract = getExtract . rightAdjunct Extract+  duplicate = getDuplicate . rightAdjunct (Duplicate . unit . unit)++ -- | @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@:@@ -94,9 +157,27 @@ initial :: c r => InitialObject c -> r initial = rightAdjunct absurd +-- | Derive the instance of @`Free` c a@ for the class @c@.+--+-- For example:+--+-- @deriveFreeInstance ''Num@+deriveFreeInstance :: Name -> Q [Dec]+deriveFreeInstance = deriveFreeInstance' ''Free 'Free 'runFree -deriveInstances ''Num-deriveInstances ''Fractional-deriveInstances ''Floating-deriveInstances ''Semigroup-deriveInstances ''Monoid+--- | 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' ''Free 'Free 'runFree++deriveFreeInstance' ''Free 'Free 'runFree ''Num+deriveFreeInstance' ''Free 'Free 'runFree ''Fractional+deriveFreeInstance' ''Free 'Free 'runFree ''Floating+deriveFreeInstance' ''Free 'Free 'runFree ''Semigroup+deriveFreeInstance' ''Free 'Free 'runFree ''Monoid++deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Fractional a) => Fractional (Ap f a)|]+deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Floating a) => Floating (Ap f a)|]
src/Data/Functor/Free/Internal.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE     GADTs   , RankNTypes+  , ViewPatterns   , TypeOperators   , DeriveFunctor   , DeriveFoldable@@ -16,112 +17,37 @@   #-} module Data.Functor.Free.Internal where -import Control.Comonad-import Data.Algebra-import Data.Algebra.TH-import Language.Haskell.TH.Syntax-import Data.Traversable---- | 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---- | @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 (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))-  => Comonad (Free c) where-  extract = getExtract . rightAdjunct Extract-  duplicate = getDuplicate . rightAdjunct (Duplicate . unit . unit)-      --class (Class f x) => Class' f x where evaluate' :: AlgebraSignature f => f x -> x-instance (Class f x) => Class' f x where evaluate' = evaluate--newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }--instance (forall x. c x => Class' f x) => Algebra f (Free c a) where-  algebra fa = Free $ \k -> evaluate' (fmap (rightAdjunct k) fa)-      -instance (Applicative f, forall x. c x => Class' s x) => Algebra s (LiftAFree c f a) where-  algebra = LiftAFree . fmap algebra . traverse getLiftAFree--instance (forall f x. Applicative f => c (LiftAFree c f x)) => Foldable (Free c) where-  foldMap = foldMapDefault+import Data.Monoid (Ap(..)) -instance (forall f x. Applicative f => c (LiftAFree c f x)) => Traversable (Free c) where-  traverse f = getLiftAFree . rightAdjunct (LiftAFree . fmap unit . f)+import Language.Haskell.TH.Syntax+import Data.DeriveLiftedInstances  -data ShowHelper a where -  ShowUnit :: a -> ShowHelper a-  ShowRec :: Show (f (ShowHelper a)) => f (ShowHelper a) -> ShowHelper a+kExp :: Q Exp+kExp = pure . VarE $ mkName "k" -instance Show (f (ShowHelper a)) => Algebra f (ShowHelper a) where-  algebra = ShowRec+kPat :: Q Pat+kPat = pure . VarP $ mkName "k" -instance Show a => Show (ShowHelper a) where-  showsPrec p (ShowUnit a) = showParen (p > 10) $ showString "unit " . showsPrec 11 a-  showsPrec p (ShowRec f) = showsPrec p f+freeDeriv :: Name -> Name -> Derivator+freeDeriv (pure . ConE -> free) (pure . VarE -> runFree) = idDeriv {+  res = \e -> [| $free (\ $kPat -> $e) |],+  var = \fold v -> [| $(fold (\w -> [| fmap $w |]) [| \f -> $runFree f $kExp |]) $v |]+} -instance (Show a, Show (Signature c (ShowHelper a)), c (ShowHelper a)) => Show (Free c a) where-  showsPrec p = showsPrec p . rightAdjunct ShowUnit+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) |] +deriveInstances' :: Name -> Name -> Name -> Name -> Q [Dec]+deriveInstances' tfree cfree runFree nm@(pure . ConT -> clss) =+  concat <$> sequenceA+    [ deriveFreeInstance' tfree cfree runFree nm+    , deriveInstance showDeriv [t| $clss ShowsPrec |]+    , deriveInstance (apDeriv idDeriv) [t| forall f a c. (Applicative f, $clss a) => $clss (Ap f a) |]+    ]  class (a => b) => a :=> b instance (a => b) => a :=> b---- | 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 = [t|forall a c. (forall x. c x :=> $clss x) => $clss (Free c a)|]-    liftAFreeHeader = [t|forall f a c. (Applicative f, forall x. c x :=> $clss x) => $clss (LiftAFree c f a)|]-    showHelperHeader = [t|forall a. Show a => $clss (ShowHelper a)|]-    clss = pure $ ConT nm
src/Data/Functor/HCofree.hs view
@@ -41,7 +41,7 @@ counit (HCofree k fa) = k fa  leftAdjunct :: c f => (f :~> g) -> f :~> HCofree c g-leftAdjunct k fa = HCofree k fa+leftAdjunct = HCofree  -- | @unit = leftAdjunct id@ unit :: c g => g :~> HCofree c g@@ -55,7 +55,7 @@ transform t (HCofree k a) = HCofree (t k) a  hfmap :: (f :~> g) -> HCofree c f :~> HCofree c g-hfmap f = transform (\k -> f . k)+hfmap f = transform (f .)  hextend :: (HCofree c f :~> g) -> HCofree c f :~> HCofree c g hextend f = transform (\k -> f . leftAdjunct k)@@ -81,6 +81,7 @@  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
src/Data/Functor/HFree.hs view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE     RankNTypes   , TypeOperators   , ConstraintKinds+  , TemplateHaskell   , UndecidableInstances   , QuantifiedConstraints   #-}@@ -24,17 +26,31 @@ module Data.Functor.HFree where  import Control.Applicative+import Control.Monad (join) import Control.Monad.Trans.Class import Data.Functor.Identity import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible +import Language.Haskell.TH.Syntax (Q, Name, Dec)+import Data.Functor.Free.Internal+ -- | Natural transformations. type f :~> g = forall b. f b -> g b  -- | The higher order free functor for constraint @c@. newtype HFree c f a = HFree { runHFree :: forall g. c g => (f :~> g) -> g a } ++-- | Derive the instance of @`HFree` c f a@ for the class @c@,.+--+-- For example:+--+-- @deriveHFreeInstance ''Functor@+deriveHFreeInstance :: Name -> Q [Dec]+deriveHFreeInstance = deriveFreeInstance' ''HFree 'HFree 'runHFree++ unit :: f :~> HFree c f unit fa = HFree $ \k -> k fa @@ -54,7 +70,7 @@ -- transform t = HFree . (. t) . runHFree  hfmap :: (f :~> g) -> HFree c f :~> HFree c g-hfmap f = transform (\k -> k . f)+hfmap f = transform (. f)  bind :: (f :~> HFree c g) -> HFree c f :~> HFree c g bind f = transform (\k -> rightAdjunct k . f)@@ -72,44 +88,19 @@ iter f = runIdentity . rightAdjunct (Identity . f)  wrap :: f (HFree Monad f a) -> HFree Monad f a-wrap as = unit as >>= id+wrap as = join (unit as)  -instance (forall x. c x => Functor x) => Functor (HFree c f) where-  fmap f (HFree g) = HFree $ \k -> fmap f (g k)-  a <$ HFree g = HFree $ \k -> a <$ g k--instance (forall x. c x => Applicative x) => Applicative (HFree c f) where-  pure a = HFree $ const (pure a)-  HFree f <*> HFree g = HFree $ \k -> f k <*> g k-  HFree f <* HFree g = HFree $ \k -> f k <* g k-  HFree f *> HFree g = HFree $ \k -> f k *> g k-  liftA2 f (HFree g) (HFree h) = HFree $ \k -> liftA2 f (g k) (h k)--instance (forall x. c x => Alternative x) => Alternative (HFree c f) where-  empty = HFree $ const empty-  HFree f <|> HFree g = HFree $ \k -> f k <|> g k-  many (HFree f) = HFree $ \k -> many (f k)-  some (HFree f) = HFree $ \k -> some (f k)+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Functor+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Applicative+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Alternative  -- | The free monad of a functor.-instance (forall x. c x => Monad x) => Monad (HFree c f) where-  return = pure-  HFree f >>= g = HFree $ \k -> f k >>= rightAdjunct k . g-  HFree f >> HFree g = HFree $ \k -> f k >> g k-  fail s = HFree $ const (fail s)+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Monad  -- HFree Monad is only a monad transformer if rightAdjunct is called with monad morphisms. -- F.e. lift . return == return fails if the results are inspected with rightAdjunct (const Nothing). -instance (forall x. c x => Contravariant x) => Contravariant (HFree c f) where-  contramap f (HFree g) = HFree $ \k -> contramap f (g k)-  a >$ HFree g = HFree $ \k -> a >$ g k--instance (forall x. c x => Divisible x) => Divisible (HFree c f) where-  divide f (HFree a) (HFree b) = HFree $ \k -> divide f (a k) (b k)-  conquer = HFree $ const conquer--instance (forall x. c x => Decidable x) => Decidable (HFree c f) where-  choose f (HFree a) (HFree b) = HFree $ \k -> choose f (a k) (b k)-  lose f = HFree $ const (lose f)+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Contravariant+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Divisible+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Decidable
src/Data/Functor/HHCofree.hs view
@@ -48,7 +48,7 @@ counit (HHCofree k fa) = k fa  leftAdjunct :: c f => (f :~~> g) -> f :~~> HHCofree c g-leftAdjunct k fa = HHCofree k fa+leftAdjunct = HHCofree  -- | @unit = leftAdjunct id@ unit :: c g => g :~~> HHCofree c g@@ -62,7 +62,7 @@ transform t (HHCofree k a) = HHCofree (t k) a  hfmap :: (f :~~> g) -> HHCofree c f :~~> HHCofree c g-hfmap f = transform (\k -> f . k)+hfmap f = transform (f .)  hextend :: (HHCofree c f :~~> g) -> HHCofree c f :~~> HHCofree c g hextend f = transform (\k -> f . leftAdjunct k)@@ -74,7 +74,7 @@ instance BifunctorComonad (HHCofree c) where   biextract = counit   biextend = hextend-  + instance ProfunctorFunctor (HHCofree c) where   promap = hfmap @@ -87,21 +87,21 @@   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)
src/Data/Functor/HHFree.hs view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE     RankNTypes   , TypeOperators   , ConstraintKinds+  , TemplateHaskell   , UndecidableInstances   , QuantifiedConstraints   #-}@@ -26,20 +28,31 @@ import Control.Arrow import Control.Category import Data.Bifunctor (Bifunctor)-import qualified Data.Bifunctor as B (Bifunctor(..)) import Data.Bifunctor.Functor-import Data.Biapplicative (Biapplicative(..))+import Data.Biapplicative (Biapplicative) import Data.Profunctor-import Data.Profunctor.Unsafe import Data.Profunctor.Monad +import Language.Haskell.TH.Syntax (Q, Name, Dec)+import Data.Functor.Free.Internal + -- | Natural transformations. type f :~~> g = forall a b. f a b -> g a b  -- | The higher order free functor over two type parameters for constraint @c@. newtype HHFree c f a b = HHFree { runHHFree :: forall g. c g => (f :~~> g) -> g a b } ++-- | Derive the instance of @`HHFree` c f a b@ for the class @c@,.+--+-- For example:+--+-- @deriveHHFreeInstance ''Category@+deriveHHFreeInstance :: Name -> Q [Dec]+deriveHHFreeInstance = deriveFreeInstance' ''HHFree 'HHFree 'runHHFree++ unit :: f :~~> HHFree c f unit fa = HHFree $ \k -> k fa @@ -59,7 +72,7 @@ -- transform t = HHFree . (. t) . runHHFree  hfmap :: (f :~~> g) -> HHFree c f :~~> HHFree c g-hfmap f = transform (\k -> k . f)+hfmap f = transform (. f)  bind :: (f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g bind f = transform (\k -> rightAdjunct k . f)@@ -79,61 +92,19 @@   projoin = bind id  -instance (forall x. c x => Category x) => Category (HHFree c f) where-  id = HHFree $ const id-  HHFree f . HHFree g = HHFree $ \k -> f k . g k--instance (forall x. c x => Arrow x) => Arrow (HHFree c f) where-  arr f = HHFree $ const (arr f)-  first (HHFree f) = HHFree $ \k -> first (f k)-  second (HHFree f) = HHFree $ \k -> second (f k)-  HHFree f *** HHFree g = HHFree $ \k -> f k *** g k-  HHFree f &&& HHFree g = HHFree $ \k -> f k &&& g k--instance (forall x. c x => ArrowZero x) => ArrowZero (HHFree c f) where-  zeroArrow = HHFree $ const zeroArrow--instance (forall x. c x => ArrowPlus x) => ArrowPlus (HHFree c f) where-  HHFree f <+> HHFree g = HHFree $ \k -> f k <+> g k--instance (forall x. c x => ArrowChoice x) => ArrowChoice (HHFree c f) where-  left (HHFree f) = HHFree $ \k -> left (f k)-  right (HHFree f) = HHFree $ \k -> right (f k)-  HHFree f +++ HHFree g = HHFree $ \k -> f k +++ g k-  HHFree f ||| HHFree g = HHFree $ \k -> f k ||| g k+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Category+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Arrow+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowZero+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowPlus+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowChoice+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowLoop  instance (forall x. c x => ArrowApply x) => ArrowApply (HHFree c f) where   app = HHFree $ \k -> app . arr (first (rightAdjunct k)) -instance (forall x. c x => ArrowLoop x) => ArrowLoop (HHFree c f) where-  loop (HHFree f) = HHFree $ \k -> loop (f k)--instance (forall x. c x => Bifunctor x) => Bifunctor (HHFree c f) where-  first f (HHFree g) = HHFree $ \k -> B.first f (g k)-  second f (HHFree g) = HHFree $ \k -> B.second f (g k)-  bimap p q (HHFree g) = HHFree $ \k -> B.bimap p q (g k)--instance (forall x. c x => Biapplicative x) => Biapplicative (HHFree c f) where-  bipure a b = HHFree $ const (bipure a b)-  HHFree f <<*>> HHFree g = HHFree $ \k -> f k <<*>> g k-  HHFree f *>> HHFree g = HHFree $ \k -> f k *>> g k-  HHFree f <<* HHFree g = HHFree $ \k -> f k <<* g k-  biliftA2 p q (HHFree g) (HHFree h) = HHFree $ \k -> biliftA2 p q (g k) (h k)--instance (forall x. c x => Profunctor x) => Profunctor (HHFree c f) where-  lmap f (HHFree g) = HHFree $ \k -> lmap f (g k)-  rmap f (HHFree g) = HHFree $ \k -> rmap f (g k)-  f #. HHFree g = HHFree $ \k -> f #. g k-  HHFree g .# f = HHFree $ \k -> g k .# f-  dimap p q (HHFree g) = HHFree $ \k -> dimap p q (g k)--instance (forall x. c x => Strong x) => Strong (HHFree c f) where-  first' (HHFree f) = HHFree $ \k -> first' (f k)-  second' (HHFree f) = HHFree $ \k -> second' (f k)--instance (forall x. c x => Choice x) => Choice (HHFree c f) where-  left' (HHFree f) = HHFree $ \k -> left' (f k)-  right' (HHFree f) = HHFree $ \k -> right' (f k)--instance (forall x. c x => Closed x) => Closed (HHFree c f) where-  closed (HHFree f) = HHFree $ \k -> closed (f k)+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Bifunctor+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Biapplicative+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Profunctor+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Strong+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Choice+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Closed