packages feed

free-functors 0.9 → 1.0

raw patch · 5 files changed

+142/−377 lines, 5 filesdep −constraints

Dependencies removed: constraints

Files

free-functors.cabal view
@@ -1,5 +1,5 @@ name:                free-functors-version:             0.9+version:             1.0 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@@ -32,16 +32,13 @@     src    exposed-modules:-    Data.Constraint.Class1,     Data.Functor.Cofree,     Data.Functor.Free,+    Data.Functor.Free.Internal,     Data.Functor.HCofree,     Data.Functor.HFree,     Data.Functor.HHCofree,     Data.Functor.HHFree-    -  other-modules:-    Data.Functor.Free.TH    default-language:     Haskell2010@@ -49,7 +46,6 @@   build-depends:     base == 4.12.*,     template-haskell == 2.14.*,-    constraints == 0.10.*,     transformers == 0.5.*,     comonad == 5.*,     algebraic-classes == 0.9.*,
− src/Data/Constraint/Class1.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE-    PolyKinds-  , DataKinds-  , RankNTypes-  , TypeFamilies-  , TypeOperators-  , ConstraintKinds-  , FlexibleContexts-  , DefaultSignatures-  , FlexibleInstances-  , ScopedTypeVariables-  , UndecidableInstances-  , MultiParamTypeClasses-  #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Constraint.HasSuperClasses--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  sjoerd@w3future.com--- Stability   :  experimental--- Portability :  non-portable-------------------------------------------------------------------------------module Data.Constraint.Class1 where--import Data.Constraint-import Data.Proxy-import Prelude hiding (id, (.))--import Control.Applicative-import Control.Arrow (Arrow, ArrowZero, ArrowPlus, ArrowLoop, ArrowApply, ArrowChoice)-import Control.Category-import Control.Comonad-import Data.Biapplicative-import Data.Functor.Contravariant-import Data.Functor.Contravariant.Divisible-import Data.Profunctor---- | 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-scls1 = containsSelf . isSubset (Proxy :: Proxy x) (Proxy :: Proxy (SuperClasses b)) (Proxy :: Proxy (SuperClasses h)) . superClasses--type SuperClass1 b h = (HasSuperClasses h, HasSuperClasses b, SuperClasses b `Subset` SuperClasses h, IsSubset (SuperClasses b) (SuperClasses h))--class HasSuperClasses (c :: k -> Constraint) where-  type SuperClasses c :: [k -> Constraint]-  type SuperClasses c = '[c]-  superClasses :: c x :- FoldConstraints (SuperClasses c) x-  default superClasses :: (SuperClasses c ~ '[c]) => c x :- FoldConstraints (SuperClasses c) x-  superClasses = Sub Dict-  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 where-  type SuperClasses Monoid = Monoid ': SuperClasses Semigroup-  superClasses = Sub Dict-  containsSelf = Sub Dict--instance HasSuperClasses Functor-instance HasSuperClasses Applicative where-  type SuperClasses Applicative = Applicative ': SuperClasses Functor-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Alternative where-  type SuperClasses Alternative = Alternative ': SuperClasses Applicative-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Monad where-  type SuperClasses Monad = Monad ': SuperClasses Applicative-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Foldable-instance HasSuperClasses Traversable where-  type SuperClasses Traversable = Traversable ': SuperClasses Functor ++ SuperClasses Foldable-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Comonad where-  type SuperClasses Comonad = Comonad ': SuperClasses Functor-  superClasses = Sub Dict-  containsSelf = Sub Dict--instance HasSuperClasses Contravariant-instance HasSuperClasses Divisible where-  type SuperClasses Divisible = Divisible ': SuperClasses Contravariant-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Decidable where-  type SuperClasses Decidable = Decidable ': SuperClasses Divisible-  superClasses = Sub Dict-  containsSelf = Sub Dict--instance HasSuperClasses Category-instance HasSuperClasses Arrow where-  type SuperClasses Arrow = Arrow ': SuperClasses Category-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses ArrowZero where-  type SuperClasses ArrowZero = ArrowZero ': SuperClasses Arrow-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses ArrowPlus where-  type SuperClasses ArrowPlus = ArrowPlus ': SuperClasses ArrowZero-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses ArrowChoice where-  type SuperClasses ArrowChoice = ArrowChoice ': SuperClasses Arrow-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses ArrowApply where-  type SuperClasses ArrowApply = ArrowApply ': SuperClasses Arrow-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses ArrowLoop where-  type SuperClasses ArrowLoop = ArrowLoop ': SuperClasses Arrow-  superClasses = Sub Dict-  containsSelf = Sub Dict--instance HasSuperClasses Bifunctor-instance HasSuperClasses Biapplicative where-  type SuperClasses Biapplicative = Biapplicative ': SuperClasses Bifunctor-  superClasses = Sub Dict-  containsSelf = Sub Dict--instance HasSuperClasses Profunctor-instance HasSuperClasses Strong where-  type SuperClasses Strong = Strong ': SuperClasses Profunctor-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Choice where-  type SuperClasses Choice = Choice ': SuperClasses Profunctor-  superClasses = Sub Dict-  containsSelf = Sub Dict-instance HasSuperClasses Closed where-  type SuperClasses Closed = Closed ': SuperClasses Profunctor-  superClasses = Sub Dict-  containsSelf = Sub Dict---type family (++) (as :: [k]) (bs :: [k]) :: [k] where-  (++) a '[] = a-  (++) '[] b = b-  (++) (a ': as) bs = a ': (as ++ bs)--type family FoldConstraints (cs :: [k -> Constraint]) (x :: k) :: Constraint-type instance FoldConstraints '[] x = ()-type instance FoldConstraints (c ': cs) x = (c x, FoldConstraints cs x)--class Elem (c :: k -> Constraint) (cs :: [k -> Constraint]) where-  isElem :: Proxy cs -> FoldConstraints cs x :- c x-instance {-# OVERLAPPING #-} Elem c (c ': cs) where-  isElem _ = weaken1-instance {-# OVERLAPPABLE #-} Elem b cs => Elem b (c ': cs) where-  isElem _ = isElem (Proxy :: Proxy cs) . weaken2--class IsSubset as bs where-  isSubset :: as `Subset` bs => Proxy x -> Proxy as -> Proxy bs -> FoldConstraints bs x :- FoldConstraints as x-instance IsSubset '[] bs where-  isSubset _ _ _ = top-instance IsSubset as bs => IsSubset (a ': as) bs where-  isSubset px _ pbs = isElem pbs &&& isSubset px (Proxy :: Proxy as) pbs--type family Subset (xs :: [k]) (ys :: [k]) :: Constraint-type instance Subset '[] bs = ()-type instance Subset (a ': as) bs = (Elem a bs, Subset as bs)
src/Data/Functor/Free.hs view
@@ -1,20 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE-    ConstraintKinds-  , GADTs-  , RankNTypes+    TypeFamilies   , TypeOperators-  , FlexibleInstances-  , MultiParamTypeClasses-  , UndecidableInstances-  , ScopedTypeVariables   , DeriveFunctor   , DeriveFoldable-  , DeriveTraversable+  , ConstraintKinds   , TemplateHaskell-  , PolyKinds-  , TypeFamilies-  , DataKinds+  , DeriveTraversable+  , FlexibleInstances+  , UndecidableInstances+  , QuantifiedConstraints+  , MultiParamTypeClasses   #-} ----------------------------------------------------------------------------- -- |@@ -60,9 +56,7 @@  import Data.Void -import Language.Haskell.TH.Syntax--import Data.Functor.Free.TH+import Data.Functor.Free.Internal  -- | @unfold f = coproduct (unfold f) unit . f@ --@@ -101,16 +95,8 @@ 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 = deriveInstances' True--deriveInstances' False ''Num-deriveInstances' False ''Fractional-deriveInstances' False ''Floating-deriveInstances' False ''Semigroup-deriveInstances' False ''Monoid+deriveInstances ''Num+deriveInstances ''Fractional+deriveInstances ''Floating+deriveInstances ''Semigroup+deriveInstances ''Monoid
+ src/Data/Functor/Free/Internal.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE+    RankNTypes+  , TypeOperators+  , DeriveFunctor+  , DeriveFoldable+  , ConstraintKinds+  , TemplateHaskell+  , DeriveTraversable+  , FlexibleInstances+  , ScopedTypeVariables+  , UndecidableInstances+  , QuantifiedConstraints+  , MultiParamTypeClasses+  , UndecidableSuperClasses+  #-}+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++instance (forall f x. Applicative f => c (LiftAFree c f x)) => Traversable (Free c) where+  traverse f = getLiftAFree . rightAdjunct (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)+++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 = getSignatureInfo nm >>= h where+  h sigInfo =+    concat <$> sequenceA+    [ deriveSignature nm+    , deriveInstanceWith_skipSignature freeHeader $ return []+    , deriveInstanceWith_skipSignature liftAFreeHeader $ return []+    , deriveInstanceWith_skipSignature showHelperHeader $ return []+    , deriveSuperclassInstances showHelperHeader+    ]+    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. $clss (ShowHelper $sig a)|]+      clss = pure $ ConT nm+      sig = pure . ConT $ signatureName sigInfo
− src/Data/Functor/Free/TH.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE-    ConstraintKinds-  , GADTs-  , RankNTypes-  , TypeOperators-  , FlexibleInstances-  , MultiParamTypeClasses-  , UndecidableInstances-  , ScopedTypeVariables-  , DeriveFunctor-  , DeriveFoldable-  , DeriveTraversable-  , TemplateHaskell-  , PolyKinds-  , DataKinds-  , QuantifiedConstraints-  #-}-module Data.Functor.Free.TH where--import Data.Constraint hiding (Class)-import Data.Constraint.Class1--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 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-    , deriveInstanceWith_skipSignature freeHeader $ return []-    , deriveInstanceWith_skipSignature liftAFreeHeader $ return []-    , deriveInstanceWith_skipSignature showHelperHeader $ return []-    , deriveSuperclassInstances showHelperHeader-    , hasSuperClassesInstance-    , [d|instance ForallLifted $c where dictLifted = Dict|]-    ]-    where-      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-      c = pure $ ConT nm-      sig = pure . ConT $ signatureName sigInfo