functor-combinators (empty) → 0.1.0.0
raw patch · 24 files changed
+6781/−0 lines, 24 filesdep +basedep +bifunctorsdep +comonadsetup-changed
Dependencies added: base, bifunctors, comonad, constraints, containers, dependent-sum, deriving-compat, free, functor-combinators, hedgehog, kan-extensions, mmorph, mtl, natural-transformation, nonempty-containers, pointed, profunctors, recursion-schemes, semigroupoids, tagged, tasty, tasty-hedgehog, these, transformers, trivial-constraint, vinyl
Files
- CHANGELOG.md +11/−0
- LICENSE +30/−0
- README.md +67/−0
- Setup.hs +2/−0
- functor-combinators.cabal +117/−0
- src/Control/Applicative/ListF.hs +318/−0
- src/Control/Applicative/Step.hs +431/−0
- src/Control/Monad/Freer/Church.hs +510/−0
- src/Control/Natural/IsoF.hs +119/−0
- src/Data/Functor/Apply/Free.hs +149/−0
- src/Data/Functor/Combinator.hs +135/−0
- src/Data/Functor/Combinator/Unsafe.hs +108/−0
- src/Data/HBifunctor.hs +120/−0
- src/Data/HBifunctor/Associative.hs +610/−0
- src/Data/HBifunctor/Tensor.hs +790/−0
- src/Data/HFunctor.hs +602/−0
- src/Data/HFunctor/Chain.hs +425/−0
- src/Data/HFunctor/Final.hs +323/−0
- src/Data/HFunctor/Internal.hs +370/−0
- src/Data/HFunctor/Interpret.hs +455/−0
- test/Spec.hs +10/−0
- test/Tests/HBifunctor.hs +484/−0
- test/Tests/HFunctor.hs +240/−0
- test/Tests/Util.hs +355/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+Changelog+=========++Version 0.1.0.0+---------------++*June 19, 2019*++<https://github.com/mstksg/functor-combinators/releases/tag/v0.1.0.0>++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Justin Le (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Justin Le nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,67 @@+functor-combinators+===================++*[Introductory Blog Post][combinatorpedia]* / *[Hackage][hackage]*++[combinatorpedia]: https://blog.jle.im/entry/functor-combinatorpedia.html+[hackage]: https://hackage.haskell.org/package/functor-combinators++Tools for working with *functor combinators*: types that take functors (or+other indexed types) and returns a new functor that "enhances" or "mixes" them+in some way.++The main functionality is exported in *Data.Functor.Combinators*, but more+fine-grained functionality and extra combinators (some of them+re-implementations for compatibility) are available in other modules as well.++The goal is to represent schemas, DSL's, and computations (things like parsers,+things to execute, things to consume or produce data) by assembling+"self-evident" basic primitives and subjecting them to many *different*+successive transformations and combiners. The process of doing so:++1. Forces you to make explicit decisions about the structure of your+ computation type as an ADT.+2. Allows you to retain isolation of fundamental parts of your domain as+ separate types+3. Lets you manipulate the structure of your final computation type through+ *normal Haskell techniques* like pattern matching. The structure is+ available throughout the entire process, so you can replace individual+ components and values within your structure.+4. Allows you to fully *reflect* the structure of your final computation+ through pattern matching and folds, so you can inspect the structure and+ produce useful summaries.++The main benefit of this library in specific is to allow you to be able to work+with different functor combinators with a uniform and lawful interface, so the+real functionality here is the wide variety of functor combinators from all+around the Haskell ecosystem. This library does not provide the functor+combinators, as much as it re-exports them with a unified interface. However,+it does "fill in the matrix", in a sense, of functor combinators in specific+roles that are missing from the haskell ecosystem.++To jump into using it, import *Data.Functor.Combinator*. For a full+introduction, check out the *[Functor Combinatorpedia][combinatorpedia]*, which+goes in-depth into the motivation behind functor combinator-driven development,+examples of the functor combinators in this library, and details about how to+use these abstractions!++Comparisons+-----------++On the surface, *functor-combinators* look like it fills a similar space to+effects systems and libraries like *[mtl][]*, *[polysemy][]*,+*[freer-simple][]*, or *[fused-effects][]*. However, the functor combinator+design pattern actually exists on a different level.++[mtl]: https://hackage.haskell.org/package/mtl+[polysemy]: https://hackage.haskell.org/package/polysemy+[freer-simple]: https://hackage.haskell.org/package/freer-simple+[fused-effects]: https://hackage.haskell.org/package/fused-effects++Functor combinator design patterns can be used to help build the *structure* of+the *data types* and schemas that define your program/DSL. Once you build+these nice structures, you then *interpret* them into some target context. This+"target context" is the realm that libraries like *mtl* and *polysemy* can+fill; functor combinators serve to help you define a structure for your program+*before* you interpret it into whatever Applicative or Monad or effects system+you end up using.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ functor-combinators.cabal view
@@ -0,0 +1,117 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 0e3342ced1438a83a4f516f9c93e10e592dc736d2962fb6a4984b86e1bcb3bd3++name: functor-combinators+version: 0.1.0.0+synopsis: Tools for functor combinator-based program design+description: Tools for working with /functor combinators/: types that take functors (or+ other indexed types) and returns a new functor that "enhances" or "mixes"+ them in some way. In the process, you can design featureful programs by+ composing smaller "primitives" using basic unversal combinators.+ .+ The main entry point is "Data.Functor.Combinators", but more fine-grained+ functionality and extra combinators (some of them re-implementations for+ compatibility) are available in other modules as well.+ .+ This library does not define new functor combinators for the most part,+ but rather re-exports them from different parts of the Haskell ecosystem+ and provides a uniform interface.+ .+ See the README for a quick overview, and also+ <https://blog.jle.im/entry/functor-combinatorpedia.html> for an in-depth+ dive into the motivation behind functor combinator-driven development,+ examples of the functor combinators in this library, and details about how+ to use these abstractions!+category: Data+homepage: https://github.com/mstksg/functor-combinators#readme+bug-reports: https://github.com/mstksg/functor-combinators/issues+author: Justin Le+maintainer: justin@jle.im+copyright: (c) Justin Le 2019+license: BSD3+license-file: LICENSE+tested-with: GHC >= 8.6+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mstksg/functor-combinators++library+ exposed-modules:+ Control.Applicative.ListF+ Control.Applicative.Step+ Control.Monad.Freer.Church+ Control.Natural.IsoF+ Data.Functor.Apply.Free+ Data.Functor.Combinator+ Data.Functor.Combinator.Unsafe+ Data.HBifunctor+ Data.HBifunctor.Associative+ Data.HBifunctor.Tensor+ Data.HFunctor+ Data.HFunctor.Chain+ Data.HFunctor.Final+ Data.HFunctor.Interpret+ other-modules:+ Data.HFunctor.Internal+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns+ build-depends:+ base >=4.12 && <5+ , bifunctors+ , comonad+ , constraints+ , containers+ , deriving-compat+ , free+ , kan-extensions+ , mmorph+ , mtl+ , natural-transformation+ , nonempty-containers+ , pointed+ , profunctors+ , recursion-schemes+ , semigroupoids+ , tagged+ , these+ , transformers+ , trivial-constraint >=0.5+ , vinyl+ default-language: Haskell2010++test-suite functor-combinators-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Tests.HBifunctor+ Tests.HFunctor+ Tests.Util+ Paths_functor_combinators+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.12 && <5+ , bifunctors+ , dependent-sum+ , free+ , functor-combinators+ , hedgehog >=1.0+ , nonempty-containers+ , semigroupoids+ , tagged+ , tasty+ , tasty-hedgehog >=1.0+ , transformers+ default-language: Haskell2010
+ src/Control/Applicative/ListF.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.Applicative.ListF+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides functor combinators that are wrappers over lists or+-- maybes of @f a@s, especially for their 'Data.Functor.HFunctor.Interpret'+-- instances.+--+-- Each one transforms a functor into some product of itself. For example,+-- @'NonEmptyF' f@ represents @f ':*:' f@, or @f :*: f :*: f@, or @f :*:+-- f :*: f :*: f@, etc.+module Control.Applicative.ListF (+ -- * 'ListF'+ ListF(..), mapListF+ -- * 'NonEmptyF'+ , NonEmptyF(.., ProdNonEmpty, nonEmptyProd), mapNonEmptyF+ , toListF, fromListF+ -- * 'MaybeF'+ , MaybeF(..), mapMaybeF+ , listToMaybeF, maybeToListF+ -- * 'MapF'+ , MapF(..)+ , NEMapF(..)+ ) where++import Control.Applicative+import Control.Natural+import Data.Coerce+import Data.Data+import Data.Deriving+import Data.Foldable+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Plus+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Pointed+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import GHC.Generics+import qualified Data.Map as M+import qualified Data.Map.NonEmpty as NEM++-- | A list of @f a@s. Can be used to describe a product of many different+-- values of type @f a@.+--+-- This is the Free 'Plus'.+newtype ListF f a = ListF { runListF :: [f a] }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''ListF+deriveRead1 ''ListF+deriveEq1 ''ListF+deriveOrd1 ''ListF++instance Apply f => Apply (ListF f) where+ ListF fs <.> ListF xs = ListF $ liftF2 (<.>) fs xs+instance Applicative f => Applicative (ListF f) where+ pure = ListF . (:[]) . pure+ ListF fs <*> ListF xs = ListF $ liftA2 (<*>) fs xs++instance Functor f => Alt (ListF f) where+ (<!>) = (<>)++instance Functor f => Plus (ListF f) where+ zero = mempty++instance Applicative f => Alternative (ListF f) where+ empty = zero+ (<|>) = (<!>)++instance Semigroup (ListF f a) where+ ListF xs <> ListF ys = ListF (xs ++ ys)++instance Monoid (ListF f a) where+ mempty = ListF []++instance Pointed f => Pointed (ListF f) where+ point = ListF . (: []) . point++-- | Map a function over the inside of a 'ListF'.+mapListF+ :: ([f a] -> [g b])+ -> ListF f a+ -> ListF g b+mapListF = coerce++-- | A non-empty list of @f a@s. Can be used to describe a product between+-- many different possible values of type @f a@.+--+-- Essentially:+--+-- @+-- 'NonEmptyF' f+-- ~ f -- one f+-- ':+:' (f ':*:' f) -- two f's+-- :+: (f :*: f :*: f) -- three f's+-- :+: (f :*: f :*: f :*: f) -- four f's+-- :+: ... -- etc.+-- @+--+-- This is the Free 'Plus'.+newtype NonEmptyF f a = NonEmptyF { runNonEmptyF :: NonEmpty (f a) }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''NonEmptyF+deriveRead1 ''NonEmptyF+deriveEq1 ''NonEmptyF+deriveOrd1 ''NonEmptyF++instance Applicative f => Applicative (NonEmptyF f) where+ pure = NonEmptyF . (:| []) . pure+ NonEmptyF fs <*> NonEmptyF xs = NonEmptyF $ liftA2 (<*>) fs xs++instance Functor f => Alt (NonEmptyF f) where+ (<!>) = (<>)++instance Semigroup (NonEmptyF f a) where+ NonEmptyF xs <> NonEmptyF ys = NonEmptyF (xs <> ys)++instance Pointed f => Pointed (NonEmptyF f) where+ point = NonEmptyF . (:| []) . point++-- | Map a function over the inside of a 'NonEmptyF'.+mapNonEmptyF+ :: (NonEmpty (f a) -> NonEmpty (g b))+ -> NonEmptyF f a+ -> NonEmptyF g b+mapNonEmptyF = coerce++-- | Convert a 'NonEmptyF' into a 'ListF' with at least one item.+toListF :: NonEmptyF f ~> ListF f+toListF (NonEmptyF xs) = ListF (toList xs)++-- | Convert a 'ListF' either a 'NonEmptyF', or a 'Proxy' in the case that+-- the list was empty.+fromListF :: ListF f ~> (Proxy :+: NonEmptyF f)+fromListF (ListF xs) = case xs of+ [] -> L1 Proxy+ y:ys -> R1 $ NonEmptyF (y :| ys)++-- | Treat a @'NonEmptyF' f@ as a product between an @f@ and a @'ListF' f@.+--+-- 'nonEmptyProd' is the record accessor.+pattern ProdNonEmpty :: (f :*: ListF f) a -> NonEmptyF f a+pattern ProdNonEmpty { nonEmptyProd+ }+ <- ((\case NonEmptyF (x :| xs) -> x :*: ListF xs) -> nonEmptyProd)+ where+ ProdNonEmpty (x :*: ListF xs) = NonEmptyF (x :| xs)+{-# COMPLETE ProdNonEmpty #-}++-- | A maybe @f a@.+--+-- Can be useful for describing a "an @f a@ that may or may not be there".+--+-- This is the free structure for a "fail"-like typeclass that would only+-- have @zero :: f a@.+newtype MaybeF f a = MaybeF { runMaybeF :: Maybe (f a) }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''MaybeF+deriveRead1 ''MaybeF+deriveEq1 ''MaybeF+deriveOrd1 ''MaybeF++instance Applicative f => Applicative (MaybeF f) where+ pure = MaybeF . Just . pure+ MaybeF f <*> MaybeF x = MaybeF $ liftA2 (<*>) f x++instance Functor f => Alt (MaybeF f) where+ (<!>) = (<>)++instance Functor f => Plus (MaybeF f) where+ zero = mempty++instance Applicative f => Alternative (MaybeF f) where+ empty = zero+ (<|>) = (<!>)++-- | Picks the first 'Just'.+instance Semigroup (MaybeF f a) where+ MaybeF xs <> MaybeF ys = MaybeF (xs <!> ys)++instance Monoid (MaybeF f a) where+ mempty = MaybeF Nothing++instance Pointed f => Pointed (MaybeF f) where+ point = MaybeF . Just . point++-- | Map a function over the inside of a 'MaybeF'.+mapMaybeF+ :: (Maybe (f a) -> Maybe (g b))+ -> MaybeF f a+ -> MaybeF g b+mapMaybeF = coerce++-- | Convert a 'MaybeF' into a 'ListF' with zero or one items.+maybeToListF :: MaybeF f ~> ListF f+maybeToListF (MaybeF x) = ListF (maybeToList x)++-- | Convert a 'ListF' into a 'MaybeF' containing the first @f a@ in the+-- list, if it exists.+listToMaybeF :: ListF f ~> MaybeF f+listToMaybeF (ListF xs) = MaybeF (listToMaybe xs)++-- | A map of @f a@s, indexed by keys of type @k@. It can be useful for+-- represeting a product of many different values of type @f a@, each "at"+-- a different @k@ location.+--+-- Can be considered a combination of 'Control.Comonad.Trans.Env.EnvT' and+-- 'ListF', in a way --- a @'MapF' k f a@ is like a @'ListF'+-- ('Control.Comonad.Trans.Env.EnvT' k f) a@ with unique (and ordered)+-- keys.+--+-- One use case might be to extend a schema with many "options", indexed by+-- some string.+--+-- For example, if you had a command line argument parser for a single+-- command+--+-- @+-- data Command a+-- @+--+-- Then you can represent a command line argument parser for /multiple/+-- named commands with+--+-- @+-- type Commands = 'MapF' 'String' Command+-- @+--+-- See 'NEMapF' for a non-empty variant, if you want to enforce that your+-- bag has at least one @f a@.+newtype MapF k f a = MapF { runMapF :: M.Map k (f a) }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''MapF+deriveEq1 ''MapF+deriveOrd1 ''MapF++instance (Ord k, Read k, Read1 f) => Read1 (MapF k f) where+ liftReadsPrec = $(makeLiftReadsPrec ''MapF)++-- | A union, combining matching keys with '<!>'.+instance (Ord k, Alt f) => Semigroup (MapF k f a) where+ MapF xs <> MapF ys = MapF $ M.unionWith (<!>) xs ys++instance (Ord k, Alt f) => Monoid (MapF k f a) where+ mempty = MapF M.empty++-- | Left-biased union+instance (Functor f, Ord k) => Alt (MapF k f) where+ MapF xs <!> MapF ys = MapF $ M.union xs ys++instance (Functor f, Ord k) => Plus (MapF k f) where+ zero = MapF M.empty++instance (Monoid k, Pointed f) => Pointed (MapF k f) where+ point = MapF . M.singleton mempty . point++-- | A non-empty map of @f a@s, indexed by keys of type @k@. It can be+-- useful for represeting a product of many different values of type @f a@,+-- each "at" a different @k@ location, where you need to have at least one+-- @f a@ at all times.+--+-- Can be considered a combination of 'Control.Comonad.Trans.Env.EnvT' and+-- 'NonEmptyF', in a way --- an @'NEMapF' k f a@ is like a @'NonEmptyF'+-- ('Control.Comonad.Trans.Env.EnvT' k f) a@ with unique (and ordered)+-- keys.+--+-- See 'MapF' for some use cases.+newtype NEMapF k f a = NEMapF { runNEMapF :: NEM.NEMap k (f a) }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''NEMapF+deriveEq1 ''NEMapF+deriveOrd1 ''NEMapF++instance (Ord k, Read k, Read1 f) => Read1 (NEMapF k f) where+ liftReadsPrec = $(makeLiftReadsPrec ''NEMapF)++instance Foldable1 f => Foldable1 (NEMapF k f) where+ fold1 = foldMap1 fold1 . runNEMapF+ foldMap1 f = (foldMap1 . foldMap1) f . runNEMapF+ toNonEmpty = foldMap1 toNonEmpty . runNEMapF++instance Traversable1 f => Traversable1 (NEMapF k f) where+ traverse1 f = fmap NEMapF . (traverse1 . traverse1) f . runNEMapF+ sequence1 = fmap NEMapF . traverse1 sequence1 . runNEMapF++-- | A union, combining matching keys with '<!>'.+instance (Ord k, Alt f) => Semigroup (NEMapF k f a) where+ NEMapF xs <> NEMapF ys = NEMapF $ NEM.unionWith (<!>) xs ys++-- | Left-biased union+instance (Functor f, Ord k) => Alt (NEMapF k f) where+ NEMapF xs <!> NEMapF ys = NEMapF $ NEM.union xs ys++instance (Monoid k, Pointed f) => Pointed (NEMapF k f) where+ point = NEMapF . NEM.singleton mempty . point+
+ src/Control/Applicative/Step.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Control.Applicative.Step+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides functor combinators that are the fixed points of+-- applications of ':+:' and 'Data.Functor.These.These1'. They are useful+-- for their 'Data.HFunctor.Interpret.Interpret' instances, along with+-- their relationship to the 'Data.HBifunctor.Tensor.Monoidal' instances of+-- ':+:' and 'Data.Functor.These.These1'.+module Control.Applicative.Step (+ -- * Fixed Points+ Step(..)+ , Steps(..)+ , Flagged(..)+ -- ** Steppers+ , stepUp+ , stepDown+ , stepping+ , stepsUp+ , stepsDown+ , steppings+ -- * Void+ , absurd1+ , Void2+ , absurd2+ , Void3+ , absurd3+ ) where++import Control.Natural+import Control.Natural.IsoF+import Data.Bifunctor+import Data.Data+import Data.Deriving+import Data.Functor.Alt+import Data.Functor.Bind+import Data.Functor.These+import Data.Map.NonEmpty (NEMap)+import Data.Pointed+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.These+import GHC.Generics+import GHC.Natural+import qualified Data.Map.NonEmpty as NEM++-- | An @f a@, along with a 'Natural' index.+--+-- @+-- 'Step' f a ~ ('Natural', f a)+-- Step f ~ ((,) Natural) ':.:' f -- functor composition+-- @+--+-- It is the fixed point of infinite applications of ':+:' (functor sums).+--+-- Intuitively, in an infinite @f :+: f :+: f :+: f ...@, you have+-- exactly one @f@ /somewhere/. A @'Step' f a@ has that @f@, with+-- a 'Natural' giving you "where" the @f@ is in the long chain.+--+-- Can be useful for using with the 'Data.HBifunctor.Tensor.Monoidal'+-- instance of ':+:'.+--+-- 'Data.HFunctor.Interpret.interpret'ing it requires no constraint on the+-- target context.+--+-- Note that this type and its instances equivalent to+-- @'Control.Comonad.Trans.Env.EnvT' ('Data.Semigroup.Sum' 'Natural')@.+data Step f a = Step { stepPos :: Natural, stepVal :: f a }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''Step+deriveRead1 ''Step+deriveEq1 ''Step+deriveOrd1 ''Step++instance Applicative f => Applicative (Step f) where+ pure = Step 0 . pure+ Step n f <*> Step m x = Step (n + m) (f <*> x)++instance Pointed f => Pointed (Step f) where+ point = Step 0 . point++instance Foldable1 f => Foldable1 (Step f) where+ fold1 = fold1 . stepVal+ foldMap1 f = foldMap1 f . stepVal+ toNonEmpty = toNonEmpty . stepVal++instance Traversable1 f => Traversable1 (Step f) where+ traverse1 f (Step n x) = Step n <$> traverse1 f x+ sequence1 (Step n x) = Step n <$> sequence1 x++-- | "Uncons and cons" an @f@ branch before a 'Step'. This is basically+-- a witness that 'stepDown' and 'stepUp' form an isomorphism.+stepping :: Step f <~> f :+: Step f+stepping = isoF stepDown stepUp++-- | Pop off the first item in a 'Step'. Because a @'Step' f@ is @f :+:+-- f :+: f :+: ...@ forever, this matches on the first branch.+--+-- You can think of it as reassociating+--+-- @+-- f :+: f :+: f :+: f :+: ...+-- @+--+-- into+--+-- @+-- f :+: ( f :+: f :+: f :+: ...)+-- @+--+-- @+-- 'stepDown' ('Step' 2 "hello")+-- -- 'R1' (Step 1 "hello")+-- stepDown (Step 0 "hello")+-- -- 'L1' "hello"+-- @+--+-- Forms an isomorphism with 'stepUp' (see 'stepping').+stepDown :: Step f ~> f :+: Step f+stepDown (Step n x) = case minusNaturalMaybe n 1 of+ Nothing -> L1 x+ Just m -> R1 (Step m x)++-- | Unshift an item into a 'Step'. Because a @'Step' f@ is @f :+: f :+:+-- f :+: f :+: ...@ forever, this basically conses an additional+-- possibility of @f@ to the beginning of it all.+--+-- You can think of it as reassociating+--+-- @+-- f :+: ( f :+: f :+: f :+: ...)+-- @+--+-- into+--+-- @+-- f :+: f :+: f :+: f :+: ...+-- @+--+-- @+-- 'stepUp' ('L1' "hello")+-- -- 'Step' 0 "hello"+-- stepUp ('R1' (Step 1 "hello"))+-- -- Step 2 "hello"+-- @+--+-- Forms an isomorphism with 'stepDown' (see 'stepping').+stepUp :: f :+: Step f ~> Step f+stepUp = \case+ L1 x -> Step 0 x+ R1 (Step n y) -> Step (n + 1) y++-- | We have a natural transformation between 'V1' and any other+-- functor @f@ with no constraints.+absurd1 :: V1 a -> f a+absurd1 = \case {}++-- | A non-empty map of 'Natural' to @f a@. Basically, contains multiple+-- @f a@s, each at a given 'Natural' index.+--+-- @+-- Steps f a ~ 'M.Map' 'Natural' (f a)+-- Steps f ~ 'M.Map' 'Natural' ':.:' f -- functor composition+-- @+--+-- It is the fixed point of applications of 'Data.Functor.These.TheseT'.+--+-- You can think of this as an infinite sparse array of @f a@s.+--+-- Intuitively, in an infinite @f \`TheseT\` f \`TheseT\` f \`TheseT\` f ...@,+-- each of those infinite positions may have an @f@ in them. However,+-- because of the at-least-one nature of 'Data.Functor.These.TheseT', we know we have at least+-- one f at one position /somewhere/.+--+-- A @'Steps' f a@ has potentially many @f@s, each stored at a different+-- 'Natural' position, with the guaruntee that at least one @f@ exists.+--+-- Can be useful for using with the 'Data.HBifunctor.Tensor.Monoidal' instance+-- of 'Data.Functor.These.TheseT'.+--+-- 'Data.HFunctor.interpret'ing it requires at least an 'Alt'+-- instance in the target context, since we have to handle potentially more+-- than one @f@.+--+-- This type is essentailly the same as @'Control.Applicative.ListF.NEMapF'+-- ('Sum' 'Natural')@ (except with a different 'Semigroup' instance).+newtype Steps f a = Steps { getSteps :: NEMap Natural (f a) }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''Steps+deriveRead1 ''Steps+deriveEq1 ''Steps+deriveOrd1 ''Steps++instance Foldable1 f => Foldable1 (Steps f) where+ fold1 = foldMap1 fold1 . getSteps+ foldMap1 f = (foldMap1 . foldMap1) f . getSteps+ toNonEmpty = foldMap1 toNonEmpty . getSteps++instance Traversable1 f => Traversable1 (Steps f) where+ traverse1 f = fmap Steps . (traverse1 . traverse1) f . getSteps+ sequence1 = fmap Steps . traverse1 sequence1 . getSteps++-- | Appends the items back-to-back, shifting all of the items in the+-- second map. Matches the behavior as the fixed-point of 'These1'.+instance Semigroup (Steps f a) where+ Steps xs <> Steps ys = Steps $+ let (k, _) = NEM.findMax xs+ in xs <> NEM.mapKeysMonotonic (+ (k + 1)) ys++-- | Left-biased untion+instance Functor f => Alt (Steps f) where+ Steps xs <!> Steps ys = Steps $ NEM.union xs ys++instance Pointed f => Pointed (Steps f) where+ point = Steps . NEM.singleton 0 . point++-- | "Uncons and cons" an @f@ branch before a 'Steps'. This is basically+-- a witness that 'stepsDown' and 'stepsUp' form an isomorphism.+steppings :: Steps f <~> These1 f (Steps f)+steppings = isoF stepsDown stepsUp++-- | Pop off the first item in a 'Steps'. Because a @'Steps' f@ is @f+-- `These1` f `These1` f `These1` ...@ forever, this matches on the first branch.+--+-- You can think of it as reassociating+--+-- @+-- f `These1` f `These1` f `These1` f `These1` ...+-- @+--+-- into+--+-- @+-- f `These1` ( f `These1` f `These1` f `These1` ...)+-- @+--+-- It returns:+--+-- * 'This1' if the first item is the /only/ item in the 'Steps'+-- * 'That1' if the first item in the 'Steps' is empty, but there are more+-- items left. The extra items are all shfited down.+-- * 'These1' if the first item in the 'Steps' exists, and there are also+-- more items left. The extra items are all shifted down.+--+-- Forms an isomorphism with 'stepsUp' (see 'steppings').+stepsDown :: Steps f ~> These1 f (Steps f)+stepsDown = these This1 That1 These1+ . bimap getFirst Steps+ . NEM.foldMapWithKey decr+ . getSteps++decr :: Natural -> f a -> These (First (f a)) (NEMap Natural (f a))+decr i x = case minusNaturalMaybe i 1 of+ Nothing -> This $ First x+ Just i' -> That $ NEM.singleton i' x++-- | Unshift an item into a 'Steps'. Because a @'Steps' f@ is @f `These1`+-- f `These1` f `These1` f `These1` ...@ forever, this basically conses an+-- additional possibility of @f@ to the beginning of it all.+--+-- You can think of it as reassociating+--+-- @+-- f `These1` ( f `These1` f `These1` f `These1` ...)+-- @+--+-- into+--+-- @+-- f `These1` f `These1` f `These1` f `These1` ...+-- @+--+-- If you give:+--+-- * 'This1', then it returns a singleton 'Steps' with one item at+-- index 0+-- * 'That1', then it shifts every item in the given 'Steps' up one+-- index.+-- * 'These1', then it shifts every item in the given 'Steps' up one+-- index, and adds the given item (the @f@) at index zero.+--+-- Forms an isomorphism with 'stepDown' (see 'stepping').+stepsUp :: These1 f (Steps f) ~> Steps f+stepsUp = \case+ This1 x -> Steps $ NEM.singleton 0 x+ That1 xs -> Steps . NEM.mapKeysMonotonic (+ 1)+ . getSteps+ $ xs+ These1 x xs -> Steps . NEM.insertMapMin 0 x+ . NEM.toMap+ . NEM.mapKeysMonotonic (+ 1)+ . getSteps+ $ xs+++-- | An @f a@, along with a 'Bool' flag+--+-- @+-- 'Flagged' f a ~ ('Bool', f a)+-- Flagged f ~ ((,) Bool) ':.:' f -- functor composition+-- @+--+-- Creation with 'Data.HFunctor.inject' or 'pure' uses 'False' as the+-- boolean.+--+-- You can think of it as an @f a@ that is "flagged" with a boolean value,+-- and that value can indicuate whether or not it is "pure" (made with+-- 'Data.HFunctor.inject' or 'pure') as 'False', or "impure"+-- (made from some other source) as 'True'. However, 'False' may be always+-- created directly, of course, using the constructor.+--+-- You can think of it like a 'Step' that is either 0 or 1, as well.+--+-- 'Data.HFunctor.Interpret.interpret'ing it requires no constraint on the+-- target context.+--+-- This type is equivalent (along with its instances) to:+--+-- * @'Data.HFunctor.HLift' 'Control.Monad.Trans.Identity.IdentityT'@+-- * @'Control.COmonad.Trans.Env.EnvT' 'Data.Semigroup.Any'@+data Flagged f a = Flagged { flaggedFlag :: Bool, flaggedVal :: f a }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''Flagged+deriveRead1 ''Flagged+deriveEq1 ''Flagged+deriveOrd1 ''Flagged++-- | Uses 'False' for 'pure', and '||' for '<*>'.+instance Applicative f => Applicative (Flagged f) where+ pure = Flagged False . pure+ Flagged n f <*> Flagged m x = Flagged (n || m) (f <*> x)++-- | Uses 'False' for 'point'.+instance Pointed f => Pointed (Flagged f) where+ point = Flagged False . point++instance Foldable1 f => Foldable1 (Flagged f) where+ fold1 = fold1 . flaggedVal+ foldMap1 f = foldMap1 f . flaggedVal+ toNonEmpty = toNonEmpty . flaggedVal++instance Traversable1 f => Traversable1 (Flagged f) where+ traverse1 f (Flagged n x) = Flagged n <$> traverse1 f x+ sequence1 (Flagged n x) = Flagged n <$> sequence1 x++++++-- | @'Void2' a b@ is uninhabited for all @a@ and @b@.+data Void2 a b+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''Void2+deriveRead1 ''Void2+deriveEq1 ''Void2+deriveOrd1 ''Void2++instance Semigroup (Void2 a b) where+ x <> _ = case x of {}++instance Alt (Void2 a) where+ x <!> _ = absurd2 x++instance Bind (Void2 a) where+ x >>- _ = case x of {}++instance Apply (Void2 a) where+ x <.> _ = case x of {}++-- | If you treat a @'Void2' f a@ as a functor combinator, then 'absurd2'+-- lets you convert from a @'Void2' f a@ into a @t f a@ for any functor+-- combinator @t@.+absurd2 :: Void2 f a -> t f a+absurd2 = \case {}++-- | @'Void3' a b@ is uninhabited for all @a@ and @b@.+data Void3 a b c+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''Void3+deriveRead1 ''Void3+deriveEq1 ''Void3+deriveOrd1 ''Void3++instance Semigroup (Void3 a b c) where+ x <> _ = case x of {}++instance Alt (Void3 a b) where+ x <!> _ = absurd3 x++instance Bind (Void3 a b) where+ x >>- _ = case x of {}++instance Apply (Void3 a b) where+ x <.> _ = case x of {}++-- | If you treat a @'Void3' f a@ as a binary functor combinator, then+-- 'absurd3' lets you convert from a @'Void3' f a@ into a @t f a@ for any+-- functor combinator @t@.+absurd3 :: Void3 f g a -> t f g a+absurd3 = \case {}
+ src/Control/Monad/Freer/Church.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.Monad.Freer.Church+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- The church-encoded "Freer" Monad. Basically provides the free monad in+-- a way that is compatible with 'Data.Functor.HFunctor.HFunctor' and+-- 'Data.Functor.HFunctor.Interpret'. We also have the "semigroup" version+-- 'Free1', which is the free 'Bind'.+--+-- The module also provides a version of 'GHC.Generics.:.:' (or+-- 'Data.Functor.Compose'), 'Comp', in a way that is compatible with+-- 'Data.Functor.Tensor.HBifunctor' and the related typeclasses.+module Control.Monad.Freer.Church (+ -- * 'Free'+ Free(..), reFree+ -- ** Interpretation+ , liftFree, interpretFree, retractFree, hoistFree+ -- ** Folding+ , foldFree, foldFree', foldFreeC+ -- * 'Free1'+ , Free1(.., DoneF1, MoreF1)+ , reFree1, toFree+ -- ** Interpretation+ , liftFree1, interpretFree1, retractFree1, hoistFree1+ -- ** Conversion+ , free1Comp, matchFree1+ -- ** Folding+ , foldFree1, foldFree1', foldFree1C+ -- * 'Comp'+ , Comp(.., Comp, unComp), comp+ ) where++import Control.Applicative+import Control.Monad+import Control.Natural+import Data.Foldable+import Data.Functor+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Coyoneda+import Data.Pointed+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import GHC.Generics+import Text.Read+import qualified Control.Monad.Free as M++-- | A @'Free' f@ is @f@ enhanced with "sequential binding" capabilities.+-- It allows you to sequence multiple @f@s one after the other, and also to+-- determine "what @f@ to sequence" based on the result of the computation+-- so far.+--+-- Essentially, you can think of this as "giving @f@ a 'Monad' instance",+-- with all that that entails ('return', '>>=', etc.).+--+-- Lift @f@ into it with @'Data.Functor.HFunctor.inject' :: f a -> Free+-- f a@. When you finally want to "use" it, you can interpret it into any+-- monadic context:+--+-- @+-- 'Data.Functor.HFunctor.interpret'+-- :: 'Monad' g+-- => (forall x. f x -> g x)+-- -> 'Free' f a+-- -> g a+-- @+--+-- Structurally, this is equivalent to many "nested" f's. A value of type+-- @'Free' f a@ is either:+--+-- * @a@+-- * @f a@+-- * @f (f a)@+-- * @f (f (f a))@+-- * .. etc.+--+-- Under the hood, this is the Church-encoded Freer monad. It's+-- 'Control.Monad.Free.Free', or 'Control.Monad.Free.Church.F', but in+-- a way that is compatible with 'Data.Functor.HFunctor.HFunctor' and+-- 'Data.Functor.HFunctor.Interpret'.+newtype Free f a = Free+ { runFree :: forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r+ }++instance Functor (Free f) where+ fmap f x = Free $ \p b -> runFree x (p . f) b++instance Apply (Free f) where+ (<.>) = ap++instance Applicative (Free f) where+ pure = return+ (<*>) = (<.>)++instance Pointed (Free f) where+ point = pure++instance Bind (Free f) where+ x >>- f = Free $ \p b -> runFree x (\y -> runFree (f y) p b) b++instance Monad (Free f) where+ return x = Free $ \p _ -> p x+ (>>=) = (>>-)++instance M.MonadFree f (Free f) where+ wrap x = Free $ \p b -> b x $ \y -> runFree y p b++instance Foldable f => Foldable (Free f) where+ foldMap f = foldFreeC f fold++instance Traversable f => Traversable (Free f) where+ traverse f = foldFree (fmap pure . f )+ (fmap M.wrap . sequenceA)++instance (Functor f, Eq1 f) => Eq1 (Free f) where+ liftEq eq x y = liftEq @(M.Free f) eq (reFree x) (reFree y)++instance (Functor f, Ord1 f) => Ord1 (Free f) where+ liftCompare c x y = liftCompare @(M.Free f) c (reFree x) (reFree y)++instance (Functor f, Eq1 f, Eq a) => Eq (Free f a) where+ (==) = eq1++instance (Functor f, Ord1 f, Ord a) => Ord (Free f a) where+ compare = compare1++instance (Functor f, Show1 f) => Show1 (Free f) where+ liftShowsPrec sp sl d x = case reFree x of+ M.Pure y -> showsUnaryWith sp "pure" d y+ M.Free ys -> showsUnaryWith (liftShowsPrec sp' sl') "wrap" d ys+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++-- | Show in terms of 'pure' and 'M.wrap'.+instance (Functor f, Show1 f, Show a) => Show (Free f a) where+ showsPrec = liftShowsPrec showsPrec showList++instance (Functor f, Read1 f) => Read1 (Free f) where+ liftReadsPrec rp rl = go+ where+ go = readsData $+ readsUnaryWith rp "pure" pure+ <> readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "wrap" M.wrap++-- | Read in terms of 'pure' and 'M.wrap'.+instance (Functor f, Read1 f, Read a) => Read (Free f a) where+ readPrec = readPrec1+ readListPrec = readListPrecDefault+ readList = readListDefault++-- | Convert a @'Free' f@ into any instance of @'M.MonadFree' f@.+reFree+ :: (M.MonadFree f m, Functor f)+ => Free f a+ -> m a+reFree = foldFree pure M.wrap++-- | Lift an @f@ into @'Free' f@, so you can use it as a 'Monad'.+--+-- This is 'Data.HFunctor.inject'.+liftFree :: f ~> Free f+liftFree x = Free $ \p b -> b x p++-- | Interpret a @'Free' f@ into a context @g@, provided that @g@ has+-- a 'Monad' instance.+--+-- This is 'Data.HFunctor.Interpret.interpret'.+interpretFree :: Monad g => (f ~> g) -> Free f ~> g+interpretFree f = foldFree' pure ((>>=) . f)++-- | Extract the @f@s back "out" of a @'Free' f@, utilizing its 'Monad'+-- instance.+--+-- This is 'Data.HFunctor.Interpret.retract'.+retractFree :: Monad f => Free f ~> f+retractFree = foldFree' pure (>>=)++-- | Swap out the underlying functor over a 'Free'. This preserves all of+-- the structure of the 'Free'.+hoistFree :: (f ~> g) -> Free f ~> Free g+hoistFree f x = Free $ \p b -> runFree x p (b . f)++-- | A version of 'foldFree' that doesn't require @'Functor' f@, by taking+-- a RankN folding function. This is essentially a flipped 'runFree'.+foldFree'+ :: (a -> r)+ -> (forall s. f s -> (s -> r) -> r)+ -> Free f a+ -> r+foldFree' f g x = runFree x f g++-- | A version of 'foldFree' that doesn't require @'Functor' f@, by folding+-- over a 'Coyoneda' instead.+foldFreeC+ :: (a -> r) -- ^ handle 'pure'+ -> (Coyoneda f r -> r) -- ^ handle 'M.wrap'+ -> Free f a+ -> r+foldFreeC f g = foldFree' f (\y n -> g (Coyoneda n y))++-- | Recursively fold down a 'Free' by handling the 'pure' case and the+-- nested/wrapped case.+--+-- This is a catamorphism.+--+-- This requires @'Functor' f@; see 'foldFree'' and 'foldFreeC' for+-- a version that doesn't require @'Functor' f@.+foldFree+ :: Functor f+ => (a -> r) -- ^ handle 'pure'+ -> (f r -> r) -- ^ handle 'M.wrap'+ -> Free f a+ -> r+foldFree f g = foldFreeC f (g . lowerCoyoneda)++-- | The Free 'Bind'. Imbues any functor @f@ with a 'Bind' instance.+--+-- Conceptually, this is "'Free' without pure". That is, while normally+-- @'Free' f a@ is an @a@, a @f a@, a @f (f a)@, etc., a @'Free1' f a@ is+-- an @f a@, @f (f a)@, @f (f (f a))@, etc. It's a 'Free' with "at least+-- one layer of @f@", excluding the @a@ case.+--+-- It can be useful as the semigroup formed by ':.:' (functor composition):+-- Sometimes we want an @f :.: f@, or an @f :.: f :.: f@, or an @f :.:+-- f :.: f :.: f@...just as long as we have at least one @f@.+newtype Free1 f a = Free1+ { runFree1 :: forall r. (forall s. f s -> (s -> a) -> r)+ -> (forall s. f s -> (s -> r) -> r)+ -> r+ }++instance Functor (Free1 f) where+ fmap f x = Free1 $ \p b -> runFree1 x (\y c -> p y (f . c)) b++instance Apply (Free1 f) where+ (<.>) = apDefault++instance Bind (Free1 f) where+ x >>- f = Free1 $ \p b ->+ runFree1 x (\y c -> b y ((\q -> runFree1 q p b) . f . c)) b++instance Foldable f => Foldable (Free1 f) where+ foldMap f = foldFree1C (foldMap f) fold++instance Traversable f => Traversable (Free1 f) where+ traverse f = foldFree1 (fmap DoneF1 . traverse f)+ (fmap MoreF1 . sequenceA )++instance Foldable1 f => Foldable1 (Free1 f) where+ foldMap1 f = foldFree1C (foldMap1 f) fold1++instance Traversable1 f => Traversable1 (Free1 f) where+ traverse1 f = foldFree1 (fmap DoneF1 . traverse1 f)+ (fmap MoreF1 . sequence1 )++instance (Functor f, Eq1 f) => Eq1 (Free1 f) where+ liftEq eq x y = liftEq @(Free f) eq (toFree x) (toFree y)++instance (Functor f, Ord1 f) => Ord1 (Free1 f) where+ liftCompare c x y = liftCompare @(Free f) c (toFree x) (toFree y)++instance (Functor f, Eq1 f, Eq a) => Eq (Free1 f a) where+ (==) = eq1++instance (Functor f, Ord1 f, Ord a) => Ord (Free1 f a) where+ compare = compare1++instance (Functor f, Show1 f) => Show1 (Free1 f) where+ liftShowsPrec sp sl d = \case+ DoneF1 x -> showsUnaryWith (liftShowsPrec sp sl ) "DoneF1" d x+ MoreF1 x -> showsUnaryWith (liftShowsPrec sp' sl') "MoreF1" d x+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++-- | Show in terms of 'DoneF1' and 'MoreF1'.+instance (Functor f, Show1 f, Show a) => Show (Free1 f a) where+ showsPrec = liftShowsPrec showsPrec showList++instance (Functor f, Read1 f) => Read1 (Free1 f) where+ liftReadsPrec rp rl = go+ where+ go = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "DoneF1" DoneF1+ <> readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "MoreF1" MoreF1++-- | Read in terms of 'DoneF1' and 'MoreF1'.+instance (Functor f, Read1 f, Read a) => Read (Free1 f a) where+ readPrec = readPrec1+ readListPrec = readListPrecDefault+ readList = readListDefault++-- | Constructor matching on the case that a @'Free1' f@ consists of just+-- a single un-nested @f@. Used as a part of the 'Show' and 'Read'+-- instances.+pattern DoneF1 :: Functor f => f a -> Free1 f a+pattern DoneF1 x <- (matchFree1 -> L1 x)+ where+ DoneF1 x = liftFree1 x++-- | Constructor matching on the case that a @'Free1' f@ is a nested @f+-- ('Free1' f a)@. Used as a part of the 'Show' and 'Read' instances.+--+-- As a constructor, this is equivalent to 'M.wrap'.+pattern MoreF1 :: Functor f => f (Free1 f a) -> Free1 f a+pattern MoreF1 x <- (matchFree1 -> R1 (Comp x))+ where+ MoreF1 x = liftFree1 x >>- id+{-# COMPLETE DoneF1, MoreF1 #-}++-- | Convert a @'Free1' f@ into any instance of @'M.MonadFree' f@.+reFree1+ :: (M.MonadFree f m, Functor f)+ => Free1 f a+ -> m a+reFree1 = foldFree1 (M.wrap . fmap pure) M.wrap++-- | @'Free1' f@ is a special subset of @'Free' f@ that consists of at least one+-- nested @f@. This converts it back into the "bigger" type.+--+-- See 'free1Comp' for a version that preserves the "one nested layer"+-- property.+toFree :: Free1 f ~> Free f+toFree x = Free $ \p b -> runFree1 x (\y c -> b y (p . c)) b++-- | Map the underlying functor under a 'Free1'.+hoistFree1 :: (f ~> g) -> Free1 f ~> Free1 g+hoistFree1 f x = Free1 $ \p b -> runFree1 x (p . f) (b . f)++-- | Because a @'Free1' f@ is just a @'Free' f@ with at least one nested+-- layer of @f@, this function converts it back into the one-nested-@f@+-- format.+free1Comp :: Free1 f ~> Comp f (Free f)+free1Comp = foldFree1' (\y c -> y :>>= (pure . c)) $ \y n ->+ y :>>= \z -> case n z of+ q :>>= m -> liftFree q >>= m++-- | Inject an @f@ into a @'Free1' f@+liftFree1 :: f ~> Free1 f+liftFree1 x = Free1 $ \p _ -> p x id++-- | Retract the @f@ out of a @'Free1' f@, as long as the @f@ implements+-- 'Bind'. Since we always have at least one @f@, we do not need a full+-- 'Monad' constraint.+retractFree1 :: Bind f => Free1 f ~> f+retractFree1 = foldFree1' (<&>) (>>-)++-- | Interpret the @'Free1' f@ in some context @g@, provided that @g@ has+-- a 'Bind' instance. Since we always have at least one @f@, we will+-- always have at least one @g@, so we do not need a full 'Monad'+-- constraint.+interpretFree1 :: Bind g => (f ~> g) -> Free1 f ~> g+interpretFree1 f = foldFree1' (\y c -> c <$> f y)+ (\y n -> f y >>- n)++-- | A @'Free1' f@ is either a single un-nested @f@, or a @f@ nested with+-- another @'Free1' f@. This decides which is the case.+matchFree1 :: forall f. Functor f => Free1 f ~> f :+: Comp f (Free1 f)+matchFree1 = foldFree1 L1 (R1 . Comp . fmap shuffle)+ where+ shuffle :: f :+: Comp f (Free1 f) ~> Free1 f+ shuffle (L1 y ) = liftFree1 y+ shuffle (R1 (y :>>= n)) = liftFree1 y >>- n++-- | A version of 'foldFree1' that doesn't require @'Functor' f@, by taking+-- a RankN folding function. This is essentially a flipped 'runFree'.+foldFree1'+ :: (forall s. f s -> (s -> a) -> r)+ -> (forall s. f s -> (s -> r) -> r)+ -> Free1 f a+ -> r+foldFree1' f g x = runFree1 x f g++-- | A version of 'foldFree1' that doesn't require @'Functor' f@, by+-- folding over a 'Coyoneda' instead.+foldFree1C+ :: (Coyoneda f a -> r)+ -> (Coyoneda f r -> r)+ -> Free1 f a+ -> r+foldFree1C f g = foldFree1' (\y c -> f (Coyoneda c y))+ (\y n -> g (Coyoneda n y))++-- | Recursively fold down a 'Free1' by handling the single @f@ case and+-- the nested/wrapped case.+--+-- This is a catamorphism.+--+-- This requires @'Functor' f@; see 'foldFree'' and 'foldFreeC' for+-- a version that doesn't require @'Functor' f@.+foldFree1+ :: Functor f+ => (f a -> r) -- ^ handle @'DoneF1'@.+ -> (f r -> r) -- ^ handle @'MoreF1'@.+ -> Free1 f a+ -> r+foldFree1 f g = foldFree1C (f . lowerCoyoneda)+ (g . lowerCoyoneda)++-- | Functor composition. @'Comp' f g a@ is equivalent to @f (g a)@, and+-- the 'Comp' pattern synonym is a way of getting the @f (g a)@ in+-- a @'Comp' f g a@.+--+-- For example, @'Maybe' ('IO' 'Bool')@ is @'Comp' 'Maybe' 'IO' 'Bool'@.+--+-- This is mostly useful for its typeclass instances: in particular,+-- 'Functor', 'Applicative', 'Data.Functor.Tensor.HBifunctor', and+-- 'Data.Functor.Tensor.Monoidal'.+--+-- This is essentially a version of 'GHC.Generics.:.:' and+-- 'Data.Functor.Compose.Compose' that allows for an+-- 'Data.Functor.Tensor.HBifunctor' instance.+--+-- It is slightly less performant. Using @'comp' . 'unComp'@ every once in+-- a while will concretize a 'Comp' value (if you have @'Functor' f@)+-- and remove some indirection if you have a lot of chained operations.+--+-- The "free monoid" over 'Comp' is 'Free', and the "free semigroup" over+-- 'Comp' is 'Free1'.+data Comp f g a =+ forall x. f x :>>= (x -> g a)++instance Functor g => Functor (Comp f g) where+ fmap f (x :>>= h) = x :>>= (fmap f . h)++instance (Applicative f, Applicative g) => Applicative (Comp f g) where+ pure x = pure () :>>= (pure . const x)+ (x :>>= f) <*> (y :>>= g) = ((,) <$> x <*> y)+ :>>= (\(x', y') -> f x' <*> g y')+ liftA2 h (x :>>= f) (y :>>= g)+ = ((,) <$> x <*> y)+ :>>= (\(x', y') -> liftA2 h (f x') (g y'))++instance (Foldable f, Foldable g) => Foldable (Comp f g) where+ foldMap f (x :>>= h) = foldMap (foldMap f . h) x++instance (Traversable f, Traversable g) => Traversable (Comp f g) where+ traverse f (x :>>= h) = (:>>= id)+ <$> traverse (traverse f . h) x++instance (Alternative f, Alternative g) => Alternative (Comp f g) where+ empty = empty :>>= id+ (x :>>= f) <|> (y :>>= g) = ((f <$> x) <|> (g <$> y)) :>>= id++instance (Functor f, Show1 f, Show1 g) => Show1 (Comp f g) where+ liftShowsPrec sp sl d (Comp x) =+ showsUnaryWith (liftShowsPrec sp' sl') "Comp" d x+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++instance (Functor f, Show1 f, Show1 g, Show a) => Show (Comp f g a) where+ showsPrec = liftShowsPrec showsPrec showList++instance (Functor f, Read1 f, Read1 g) => Read1 (Comp f g) where+ liftReadPrec rp rl = readData $+ readUnaryWith (liftReadPrec rp' rl') "Comp" Comp+ where+ rp' = liftReadPrec rp rl+ rl' = liftReadListPrec rp rl++instance (Functor f, Read1 f, Read1 g, Read a) => Read (Comp f g a) where+ readPrec = readPrec1+ readListPrec = readListPrecDefault+ readList = readListDefault++instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Comp f g) where+ liftEq eq (Comp x) (Comp y) = liftEq (liftEq eq) x y++instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Comp f g) where+ liftCompare c (Comp x) (Comp y) = liftCompare (liftCompare c) x y++instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Comp f g a) where+ (==) = eq1++instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Comp f g a) where+ compare = compare1++-- | "Smart constructor" for 'Comp' that doesn't require @'Functor' f@.+comp :: f (g a) -> Comp f g a+comp = (:>>= id)++-- | Pattern match on and construct a @'Comp' f g a@ as if it were @f+-- (g a)@.+pattern Comp :: Functor f => f (g a) -> Comp f g a+pattern Comp { unComp } <- ((\case x :>>= f -> f <$> x)->unComp)+ where+ Comp x = comp x+{-# COMPLETE Comp #-}+
+ src/Control/Natural/IsoF.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Control.Natural.IsoF+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Types describing isomorphisms between two functors, and functions to+-- manipulate them.+module Control.Natural.IsoF (+ type (~>)+ , type (<~>)+ , isoF+ , viewF, reviewF, overF+ , fromF+ , Exchange(..)+ ) where++import Data.Profunctor+import Control.Natural+import Data.Tagged++-- | The type of an isomorphism between two functors. @f <~> g@ means that+-- @f@ and @g@ are isomorphic to each other.+--+-- We can effectively /use/ an @f <~> g@ with:+--+-- @+-- 'viewF' :: (f <~> g) -> f a -> g a+-- 'reviewF' :: (f <~> g) -> g a -> a a+-- @+--+-- Use 'viewF' to extract the "@f@ to @g@" function, and 'reviewF' to+-- extract the "@g@ to @f@" function. Reviewing and viewing the same value+-- (or vice versa) leaves the value unchanged.+--+-- One nice thing is that we can compose isomorphisms using '.' from+-- "Prelude":+--+-- @+-- ('.') :: f <~> g+-- -> g <~> h+-- -> f <~> h+-- @+--+-- One nice thing about this representation is that we have the "identity"+-- isomorphism by using 'id' from "Prelude".+--+-- @+-- 'id' :: f '<~>' g+-- @+--+-- As a convention, most isomorphisms have form "X-ing", where the+-- forwards function is "ing". For example, we have:+--+-- @+-- 'Data.HBifunctor.Tensor.splittingSF' :: 'Data.HBifunctor.Tensor.Monoidal' t => 'Data.HBifunctor.Associative.SF' t a '<~>' t f ('Data.HBifunctor.Tensor.MF' t f)+-- 'Data.HBifunctor.Tensor.splitSF' :: Monoidal t => SF t a '~>' t f (MF t f)+-- @+type f <~> g = forall p a. Profunctor p => p (g a) (g a) -> p (f a) (f a)+infixr 0 <~>++-- | Create an @f '<~>' g@ by providing both legs of the isomorphism (the+-- @f a -> g a@ and the @g a -> f a@.+isoF+ :: f ~> g+ -> g ~> f+ -> f <~> g+isoF = dimap++-- | Use a '<~>' by retrieving the "forward" function:+--+-- @+-- 'viewF' :: (f <~> g) -> f a -> g a+-- @+viewF :: f <~> g -> f ~> g+viewF i = runForget (i (Forget id))++-- | Use a '<~>' by retrieving the "backwards" function:+--+-- @+-- 'viewF' :: (f <~> g) -> f a -> g a+-- @+reviewF :: f <~> g -> g ~> f+reviewF i x = unTagged (i (Tagged x))++-- | Lift a function @g a ~> g a@ to be a function @f a -> f a@, given an+-- isomorphism between the two.+--+-- One neat thing is that @'overF' i id == id@.+overF :: f <~> g -> g ~> g -> f ~> f+overF i f = i f++-- | Reverse an isomorphism.+--+-- @+-- 'viewF' ('fromF' i) == 'reviewF' i+-- 'reviewF' ('fromF' i) == 'viewF' i+-- @+fromF+ :: f <~> g+ -> g <~> f+fromF i = isoF g f+ where+ Exchange f g = i (Exchange id id)++-- | Profunctor that allows us to implement 'fromF'.+data Exchange a b s t = Exchange (s -> a) (b -> t)+ deriving Functor++instance Profunctor (Exchange a b) where+ dimap f g (Exchange x y) = Exchange (x . f) (g . y)
+ src/Data/Functor/Apply/Free.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.Functor.Apply.Free+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- The free 'Apply'. Provides 'Ap1' and various utility methods. See+-- 'Ap1' for more details.+--+-- Ideally 'Ap1' would be in the /free/ package. However, it is defined+-- here for now.+module Data.Functor.Apply.Free (+ Ap1(.., DayAp1, ap1Day)+ , toAp, fromAp+ , liftAp1+ , retractAp1+ , runAp1+ ) where++import Control.Applicative.Free+import Control.Natural+import Data.Function+import Data.Functor.Apply+import Data.Functor.Day+import Data.Functor.Identity+import Data.HFunctor+import Data.HFunctor.Interpret+import Data.Kind+import GHC.Generics++-- | One or more @f@s convolved with itself.+--+-- Essentially:+--+-- @+-- 'Ap1' f+-- ~ f -- one f+-- ':+:' (f \`'Day'` f) -- two f's+-- :+: (f \`Day\` f \`Day\` f) -- three f's+-- :+: (f \`Day\` f \`Day\` f \`Day\` f) -- four f's+-- :+: ... -- etc.+-- @+--+-- Useful if you want to promote an @f@ to a situation with "at least one+-- @f@ sequenced with itself".+--+-- Mostly useful for its 'HFunctor' and 'Interpret' instance, along with+-- its relationship with 'Ap' and 'Day'.+--+-- This is the free 'Apply' --- Basically a "non-empty" 'Ap'.+--+-- The construction here is based on 'Ap', similar to now+-- 'Data.List.NonEmpty.NonEmpty' is built on list.+data Ap1 :: (Type -> Type) -> Type -> Type where+ Ap1 :: f a -> Ap f (a -> b) -> Ap1 f b++-- | An 'Ap1' is a "non-empty" 'Ap'; this function "forgets" the non-empty+-- property and turns it back into a normal 'Ap'.+toAp :: Ap1 f ~> Ap f+toAp (Ap1 x xs) = Ap x xs++-- | Convert an 'Ap' into an 'Ap1' if possible. If the 'Ap' was "empty",+-- return the 'Pure' value instead.+fromAp :: Ap f ~> (Identity :+: Ap1 f)+fromAp = \case+ Pure x -> L1 $ Identity x+ Ap x xs -> R1 $ Ap1 x xs++-- | An @'Ap1' f@ is just a @'Day' f ('Ap' f)@. This bidirectional pattern+-- synonym lets you treat it as such.+pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a+pattern DayAp1 { ap1Day } <- ((\case Ap1 x y -> Day x y (&)) -> ap1Day)+ where+ DayAp1 (Day x y f) = Ap1 x (flip f <$> y)+{-# COMPLETE DayAp1 #-}++deriving instance Functor (Ap1 f)++instance Apply (Ap1 f) where+ Ap1 x xs <.> ys = Ap1 x (flip <$> xs <*> toAp ys)++-- | Embed an @f@ into 'Ap1'.+liftAp1 :: f ~> Ap1 f+liftAp1 x = Ap1 x (Pure id)++-- | Extract the @f@ out of the 'Ap1'.+--+-- @+-- 'retractAp1' . 'liftAp1' == id+-- @+retractAp1 :: Apply f => Ap1 f ~> f+retractAp1 (Ap1 x xs) = retractAp1_ x xs++-- | Interpret an @'Ap' f@ into some 'Apply' context @g@.+runAp1+ :: Apply g+ => (f ~> g)+ -> Ap1 f ~> g+runAp1 f (Ap1 x xs) = runAp1_ f x xs++instance HFunctor Ap1 where+ hmap f (Ap1 x xs) = Ap1 (f x) (hmap f xs)++instance Inject Ap1 where+ inject = liftAp1++instance HBind Ap1 where+ hbind = runAp1++instance Interpret Ap1 where+ type C Ap1 = Apply++ retract = retractAp1+ interpret = runAp1++retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b+retractAp1_ x = \case+ Pure y -> y <$> x+ Ap y ys -> (&) <$> x <.> retractAp1_ y ys++runAp1_+ :: forall f g a b. Apply g+ => (f ~> g)+ -> f a+ -> Ap f (a -> b)+ -> g b+runAp1_ f = go+ where+ go :: f x -> Ap f (x -> y) -> g y+ go x = \case+ Pure y -> y <$> f x+ Ap y ys -> (&) <$> f x <.> go y ys+
+ src/Data/Functor/Combinator.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ExplicitNamespaces #-}++-- |+-- Module : Data.Functor.Combinator+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Functor combinators and tools (typeclasses and utiility functions) to+-- manipulate them. This is the main "entrypoint" of the library.+--+-- Classes include:+--+-- * 'HFunctor' and 'HBifunctor', used to swap out the functors that the+-- combinators modify+-- * 'Interpret', 'Associative', 'Monoidal', used to inject and interpret+-- functor values with respect to their combinators.+--+-- We have some helpful utility functions, as well, built on top of these+-- typeclasses.+--+-- The second half of this module exports the various useful functor+-- combinators that can modify functors to add extra functionality, or join+-- two functors together and mix them in different ways. Use them to build+-- your final structure by combining simpler ones in composable ways!+--+-- See <https://blog.jle.im/entry/functor-combinatorpedia.html> and the+-- README for a tutorial and a rundown on each different functor+-- combinator.+module Data.Functor.Combinator (+ -- * Classes+ -- | A lot of type signatures are stated in terms of '~>'. '~>'+ -- represents a "natural transformation" between two functors: a value of+ -- type @f '~>' g@ is a value of type 'f a -> g a@ that works for /any/+ -- @a@.+ type (~>)+ , type (<~>)+ -- ** Single Functors+ -- | Classes that deal with single-functor combinators, that enhance+ -- a single functor.+ , HFunctor(..)+ , Inject(..)+ , Interpret(..)+ , forI+ , getI+ , collectI+ -- ** Multi-Functors+ -- | Classes that deal with two-functor combinators, that "mix" two+ -- functors together in some way.+ , HBifunctor(..)+ -- *** Associative+ , Associative(..)+ , Semigroupoidal(SF, appendSF, consSF, toSF, biretract, binterpret)+ , CS+ , biget, bicollect+ , (!*!)+ , (!$!)+ -- *** Tensor+ , Tensor(..)+ , Monoidal(MF, appendMF, splitSF, toMF, fromSF, pureT, upgradeC)+ , CM+ , nilMF, consMF+ , inL, inR+ , outL, outR+ -- * Combinators+ -- | Functor combinators+ -- ** Single+ , Coyoneda(..)+ , ListF(..)+ , NonEmptyF(..)+ , MaybeF(..)+ , MapF(..)+ , NEMapF(..)+ , Ap+ , Ap1(..)+ , Alt+ , Free+ , Free1+ , Lift+ , Step(..)+ , Steps(..)+ , ProxyF(..)+ , ConstF(..)+ , EnvT(..)+ , ReaderT(..)+ , Flagged(..)+ , IdentityT(..)+ , Void2+ , Final(..)+ , FreeOf(..)+ , ComposeT(..)+ -- ** Multi+ , Day(..)+ , (:*:)(..), prodOutL, prodOutR+ , (:+:)(..), V1+ , These1(..)+ , Comp(Comp, unComp)+ , LeftF(..)+ , RightF(..)+ -- ** Combinator Combinators+ , HLift(..)+ , HFree(..)+ -- * Util+ -- ** Natural Transformations+ , generalize+ , absorb+ ) where++import Control.Alternative.Free+import Control.Applicative.Free+import Control.Applicative.Lift+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Comonad.Trans.Env+import Control.Monad.Freer.Church+import Control.Monad.Trans.Compose+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader+import Control.Natural+import Control.Natural.IsoF+import Data.Functor.Apply.Free+import Data.Functor.Coyoneda+import Data.Functor.Day+import Data.Functor.These+import Data.HBifunctor+import Data.HBifunctor.Associative+import Data.HBifunctor.Tensor+import Data.HFunctor+import Data.HFunctor.Final+import Data.HFunctor.Internal+import Data.HFunctor.Interpret+import GHC.Generics
+ src/Data/Functor/Combinator/Unsafe.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module : Data.Functor.Combinator.Unsafe+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Working with non-standard typeclasses like 'Plus', 'Apply', 'Bind', and+-- 'Pointed' will sometimes cause problems when using with libraries that+-- do not provide instances, even though their types already are instances+-- of 'Alternative' or 'Applicative' or 'Monad'.+--+-- This module provides unsafe methods to "promote" 'Applicative' instances+-- to 'Apply', 'Alternative' to 'Plus', etc.+--+-- They are unsafe in the sense that if those types /already/ have those+-- instances, this will cause overlapping instances errors or problems with+-- coherence. Because of this, you should always use these with /specific/+-- @f@s, and never in a polymorphic way over @f@.+module Data.Functor.Combinator.Unsafe (+ unsafePlus+ , unsafeApply+ , unsafeBind+ , unsafePointed+ ) where++import Control.Applicative+import Data.Constraint+import Data.Constraint.Unsafe+import Data.Functor.Bind+import Data.Functor.Plus+import Data.Pointed++-- | For any @'Alternative' f@, produce a value that would require @'Plus'+-- f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Plus' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+unsafePlus :: forall f proxy r. Alternative f => proxy f -> (Plus f => r) -> r+unsafePlus _ x = case unsafeCoerceConstraint @(Plus (WrappedApplicative f)) @(Plus f) of+ Sub Dict -> x++-- | For any @'Applicative' f@, produce a value that would require @'Apply'+-- f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Apply' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+unsafeApply :: forall f proxy r. Applicative f => proxy f -> (Apply f => r) -> r+unsafeApply _ x = case unsafeCoerceConstraint @(Apply (WrappedApplicative f)) @(Apply f) of+ Sub Dict -> x++-- | For any @'Monad' f@, produce a value that would require @'Bind'+-- f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Bind' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+unsafeBind :: forall f proxy r. Monad f => proxy f -> (Bind f => r) -> r+unsafeBind _ x = case unsafeCoerceConstraint @(Bind (WrappedMonad f)) @(Bind f) of+ Sub Dict -> x++newtype PointMe f a = PointMe (f a)++instance Applicative f => Pointed (PointMe f) where+ point = PointMe . pure++-- | For any @'Applicative' f@, produce a value that would require+-- @'Pointed' f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Pointed' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+unsafePointed :: forall f proxy r. Applicative f => proxy f -> (Pointed f => r) -> r+unsafePointed _ x = case unsafeCoerceConstraint @(Pointed (PointMe f)) @(Pointed f) of+ Sub Dict -> x+
+ src/Data/HBifunctor.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.HBifunctor+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides an abstraction for "two-argument functor+-- combinators", 'HBifunctor', as well as some useful combinators.+module Data.HBifunctor (+ HBifunctor(..)+ , WrappedHBifunctor(..)+ , overHBifunctor+ -- * Simple Instances+ , LeftF(..)+ , RightF(..)+ ) where++import Control.Natural.IsoF+import Data.Biapplicative+import Data.Bifunctor.TH+import Data.Constraint.Trivial+import Data.Data+import Data.Deriving+import Data.HFunctor+import Data.HFunctor.Internal+import Data.HFunctor.Interpret+import GHC.Generics++-- | Lift two isomorphisms on each side of a bifunctor to become an+-- isomorphism between the two bifunctor applications.+--+-- Basically, if @f@ and @f'@ are isomorphic, and @g@ and @g'@ are+-- isomorphic, then @t f g@ is isomorphic to @t f' g'@.+overHBifunctor+ :: HBifunctor t+ => (f <~> f')+ -> (g <~> g')+ -> t f g <~> t f' g'+overHBifunctor f g =+ isoF (hbimap (viewF f) (viewF g))+ (hbimap (reviewF f) (reviewF g))++-- | An 'HBifunctor' that ignores its second input. Like+-- a 'GHC.Generics.:+:' with no 'GHC.Generics.R1'/right branch.+--+-- This is 'Data.Bifunctors.Joker.Joker' from "Data.Bifunctors.Joker", but+-- given a more sensible name for its purpose.+newtype LeftF f g a = LeftF { runLeftF :: f a }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''LeftF+deriveRead1 ''LeftF+deriveEq1 ''LeftF+deriveOrd1 ''LeftF+deriveBifunctor ''LeftF+deriveBifoldable ''LeftF+deriveBitraversable ''LeftF++instance Applicative f => Biapplicative (LeftF f) where+ bipure _ y = LeftF (pure y)+ LeftF x <<*>> LeftF y = LeftF (x <*> y)++instance HBifunctor LeftF where+ hbimap f _ (LeftF x) = LeftF (f x)++deriving via (WrappedHBifunctor LeftF f)+ instance HFunctor (LeftF f)++-- | An 'HBifunctor' that ignores its first input. Like+-- a 'GHC.Generics.:+:' with no 'GHC.Generics.L1'/left branch.+--+-- In its polykinded form (on @f@), it is essentially a higher-order+-- version of 'Data.Tagged.Tagged'.+newtype RightF f g a = RightF { runRightF :: g a }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''RightF+deriveRead1 ''RightF+deriveEq1 ''RightF+deriveOrd1 ''RightF++instance HBifunctor RightF where+ hbimap _ g (RightF x) = RightF (g x)++deriving via (WrappedHBifunctor RightF f)+ instance HFunctor (RightF f)++instance HFunctor (RightF f) where+ hmap f (RightF x) = RightF (f x)++instance Inject (RightF f) where+ inject = RightF++instance HBind (RightF f) where+ hbind f (RightF x) = f x++instance Interpret (RightF f) where+ type C (RightF f) = Unconstrained+ retract (RightF x) = x+ interpret f (RightF x) = f x
+ src/Data/HBifunctor/Associative.hs view
@@ -0,0 +1,610 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.HBifunctor.Associative+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides tools for working with binary functor combinators+-- that represent interpretable schemas.+--+-- These are types @'HBifunctor' t@ that take two functors @f@ and @g@ and returns a new+-- functor @t f g@, that "mixes together" @f@ and @g@ in some way.+--+-- The high-level usage of this is+--+-- @+-- 'biretract' :: t f f ~> f+-- @+--+-- which lets you fully "mix" together the two input functors.+--+-- This class also associates each 'HBifunctor' with its "semigroup functor+-- combinator", so we can "squish together" repeated applications of @t@.+--+-- That is, an @'SF' t f a@ is either:+--+-- * @f a@+-- * @t f f a@+-- * @t f (t f f) a@+-- * @t f (t f (t f f)) a@+-- * .. etc.+--+-- which means we can have "list-like" schemas that represent multiple+-- copies of @f@.+--+-- See "Data.HBifunctor.Tensor" for a version that also provides an analogy+-- to 'inject', and a more flexible "squished" combinator+-- 'Data.HBifunctor.Tensor.MF' that has an "empty" element.+module Data.HBifunctor.Associative (+ -- * 'Associative'+ Associative(..)+ , assoc+ , disassoc+ -- * 'Semigroupoidal'+ , Semigroupoidal(..)+ , CS+ , matchingSF+ -- ** Utility+ , biget+ , bicollect+ , (!*!)+ , (!$!)+ ) where++import Control.Applicative+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Monad.Freer.Church+import Control.Monad.Trans.Compose+import Control.Natural+import Control.Natural.IsoF+import Data.Bifunctor.Joker+import Data.Coerce+import Data.Data+import Data.Foldable+import Data.Functor.Apply.Free+import Data.Functor.Bind+import Data.Functor.Day (Day(..))+import Data.Functor.Identity+import Data.Functor.Plus+import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.These+import Data.HBifunctor+import Data.HFunctor+import Data.HFunctor.Internal+import Data.HFunctor.Interpret+import Data.Kind+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Generics hiding (C)+import qualified Data.Functor.Day as D+import qualified Data.Map.NonEmpty as NEM++-- | An 'HBifunctor' where it doesn't matter which binds first is+-- 'Associative'. Knowing this gives us a lot of power to rearrange the+-- internals of our 'HFunctor' at will.+--+-- For example, for the functor product:+--+-- @+-- data (f ':*:' g) a = f a :*: g a+-- @+--+-- We know that @f :*: (g :*: h)@ is the same as @(f :*: g) :*: h@.+class HBifunctor t => Associative t where+ -- | The isomorphism between @t f (t g h) a@ and @t (t f g) h a@. To+ -- use this isomorphism, see 'assoc' and 'disassoc'.+ associating+ :: (Functor f, Functor g, Functor h)+ => t f (t g h) <~> t (t f g) h+ {-# MINIMAL associating #-}++-- | Reassociate an application of @t@.+assoc+ :: (Associative t, Functor f, Functor g, Functor h)+ => t f (t g h)+ ~> t (t f g) h+assoc = viewF associating++-- | Reassociate an application of @t@.+disassoc+ :: (Associative t, Functor f, Functor g, Functor h)+ => t (t f g) h+ ~> t f (t g h)+disassoc = reviewF associating++-- | For some @t@s, you can represent the act of applying a functor @f@ to+-- @t@ many times, as a single type. That is, there is some type @'SF'+-- t f@ that is equivalent to one of:+--+-- * @f a@ -- 1 time+-- * @t f f a@ -- 2 times+-- * @t f (t f f) a@ -- 3 times+-- * @t f (t f (t f f)) a@ -- 4 times+-- * @t f (t f (t f (t f f))) a@ -- 5 times+-- * .. etc+--+-- This typeclass associates each @t@ with its "induced semigroupoidal+-- functor combinator" @'SF' t@.+--+-- This is useful because sometimes you might want to describe a type that+-- can be @t f f@, @t f (t f f)@, @t f (t f (t f f))@, etc.; "f applied to+-- itself", with at least one @f@. This typeclass lets you use a type like+-- 'NonEmptyF' in terms of repeated applications of ':*:', or 'Ap1' in+-- terms of repeated applications of 'Day', or 'Free1' in terms of repeated+-- applications of 'Comp', etc.+--+-- For example, @f ':*:' f@ can be interpreted as "a free selection of two+-- @f@s", allowing you to specify "I have to @f@s that I can use". If you+-- want to specify "I want 1, 2, or many different @f@s that I can use",+-- you can use @'NonEmptyF' f@.+--+-- At the high level, the main way to /use/ a 'Semigroupoidal' is with+-- 'biretract' and 'binterpret':+--+-- @+-- 'biretract' :: t f f '~>' f+-- 'binterpret' :: (f ~> h) -> (g ~> h) -> t f g ~> h+-- @+--+-- which are like the 'HBifunctor' versions of 'retract' and 'interpret':+-- they fully "mix" together the two inputs of @t@.+--+-- Also useful is:+--+-- @+-- 'toSF' :: t f f a -> SF t f a+-- @+--+-- Which converts a @t@ into its aggregate type 'SF'.+--+-- In reality, most 'Semigroupoidal' instances are also+-- 'Data.HBifunctor.Tensor.Monoidal' instances, so you can think of the+-- separation as mostly to help organize functionality. However, there are+-- two non-monoidal semigroupoidal instances of note: 'LeftF' and 'RightF',+-- which are higher order analogues of the 'Data.Semigroup.First' and+-- 'Data.Semigroup.Last' semigroups, roughly.+class (Associative t, Interpret (SF t)) => Semigroupoidal t where+ -- | The "semigroup functor combinator" generated by @t@.+ --+ -- A value of type @SF t f a@ is /equivalent/ to one of:+ --+ -- * @f a@+ -- * @t f f a@+ -- * @t f (t f f) a@+ -- * @t f (t f (t f f)) a@+ -- * @t f (t f (t f (t f f))) a@+ -- * .. etc+ --+ -- For example, for ':*:', we have 'NonEmptyF'. This is because:+ --+ -- @+ -- x ~ 'NonEmptyF' (x ':|' []) ~ 'inject' x+ -- x ':*:' y ~ NonEmptyF (x :| [y]) ~ 'toSF' (x :*: y)+ -- x :*: y :*: z ~ NonEmptyF (x :| [y,z])+ -- -- etc.+ -- @+ --+ -- You can create an "singleton" one with 'inject', or else one from+ -- a single @t f f@ with 'toSF'.+ type SF t :: (Type -> Type) -> Type -> Type++ -- | If a @'SF' t f@ represents multiple applications of @t f@ to+ -- itself, then we can also "append" two @'SF' t f@s applied to+ -- themselves into one giant @'SF' t f@ containing all of the @t f@s.+ appendSF :: t (SF t f) (SF t f) ~> SF t f+ matchSF :: Functor f => SF t f ~> f :+: t f (SF t f)++ -- | Prepend an application of @t f@ to the front of a @'SF' t f@.+ consSF :: t f (SF t f) ~> SF t f+ consSF = appendSF . hleft inject++ -- | Embed a direct application of @f@ to itself into a @'SF' t f@.+ toSF :: t f f ~> SF t f+ toSF = consSF . hright inject++ -- | The 'HBifunctor' analogy of 'retract'. It retracts /both/ @f@s+ -- into a single @f@, effectively fully mixing them together.+ biretract :: CS t f => t f f ~> f+ biretract = retract . toSF++ -- | The 'HBifunctor' analogy of 'interpret'. It takes two+ -- interpreting functions, and mixes them together into a target+ -- functor @h@.+ binterpret+ :: CS t h+ => f ~> h+ -> g ~> h+ -> t f g ~> h+ binterpret f g = retract . toSF . hbimap f g++ {-# MINIMAL appendSF, matchSF #-}++-- | Convenient alias for the constraint required for 'biretract',+-- 'binterpret', etc.+--+-- It's usually a constraint on the target/result context of interpretation+-- that allows you to "exit" or "run" a @'Semigroupoidal' t@.+type CS t = C (SF t)++-- | An @'SF' t f@ represents the successive application of @t@ to @f@,+-- over and over again. So, that means that an @'SF' t f@ must either be+-- a single @f@, or an @t f (SF t f)@.+--+-- 'matchingSF' states that these two are isomorphic. Use 'matchSF' and+-- @'inject' '!*!' 'consSF'@ to convert between one and the other.+matchingSF :: (Semigroupoidal t, Functor f) => SF t f <~> f :+: t f (SF t f)+matchingSF = isoF matchSF (inject !*! consSF)++-- | Useful wrapper over 'binterpret' to allow you to directly extract+-- a value @b@ out of the @t f a@, if you can convert @f x@ into @b@.+--+-- Note that depending on the constraints on the interpretation of @t@, you+-- may have extra constraints on @b@.+--+-- * If @'C' ('SF' t)@ is 'Data.Constraint.Trivial.Unconstrained', there+-- are no constraints on @b@+-- * If @'C' ('SF' t)@ is 'Apply', @b@ needs to be an instance of 'Semigroup'+-- * If @'C' ('SF' t)@ is 'Applicative', @b@ needs to be an instance of 'Monoid'+--+-- For some constraints (like 'Monad'), this will not be usable.+--+-- @+-- -- Return the length of either the list, or the Map, depending on which+-- -- one s in the '+'+-- 'biget' 'length' length+-- :: ([] :+: 'Data.Map.Map' 'Int') 'Char'+-- -> Int+--+-- -- Return the length of both the list and the map, added together+-- 'biget' ('Data.Monoid.Sum' . length) (Sum . length)+-- :: 'Day' [] (Map Int) Char+-- -> Sum Int+-- @+biget+ :: (Semigroupoidal t, CS t (Const b))+ => (forall x. f x -> b)+ -> (forall x. g x -> b)+ -> t f g a+ -> b+biget f g = getConst . binterpret (Const . f) (Const . g)++-- | Infix alias for 'biget'+--+-- @+-- -- Return the length of either the list, or the Map, depending on which+-- -- one s in the '+'+-- 'length' '!$!' length+-- :: ([] :+: 'Data.Map.Map' 'Int') 'Char'+-- -> Int+--+-- -- Return the length of both the list and the map, added together+-- 'Data.Monoid.Sum' . length !$! Sum . length+-- :: 'Day' [] (Map Int) Char+-- -> Sum Int+-- @+(!$!)+ :: (Semigroupoidal t, CS t (Const b))+ => (forall x. f x -> b)+ -> (forall x. g x -> b)+ -> t f g a+ -> b+(!$!) = biget+infixr 5 !$!++-- | Infix alias for 'binterpret'+(!*!)+ :: (Semigroupoidal t, CS t h)+ => (f ~> h)+ -> (g ~> h)+ -> t f g+ ~> h+(!*!) = binterpret+infixr 5 !*!++-- | Useful wrapper over 'biget' to allow you to collect a @b@ from all+-- instances of @f@ and @g@ inside a @t f g a@.+--+-- This will work if @'C' t@ is 'Data.Constraint.Trivial.Unconstrained',+-- 'Apply', or 'Applicative'.+bicollect+ :: (Semigroupoidal t, CS t (Const [b]))+ => (forall x. f x -> b)+ -> (forall x. g x -> b)+ -> t f g a+ -> [b]+bicollect f g = biget ((:[]) . f) ((:[]) . g)++instance Associative (:*:) where+ associating = isoF to_ from_+ where+ to_ (x :*: (y :*: z)) = (x :*: y) :*: z+ from_ ((x :*: y) :*: z) = x :*: (y :*: z)++instance Associative Product where+ associating = isoF to_ from_+ where+ to_ (Pair x (Pair y z)) = Pair (Pair x y) z+ from_ (Pair (Pair x y) z) = Pair x (Pair y z)++instance Associative Day where+ associating = isoF D.assoc D.disassoc++instance Associative (:+:) where+ associating = isoF to_ from_+ where+ to_ = \case+ L1 x -> L1 (L1 x)+ R1 (L1 y) -> L1 (R1 y)+ R1 (R1 z) -> R1 z+ from_ = \case+ L1 (L1 x) -> L1 x+ L1 (R1 y) -> R1 (L1 y)+ R1 z -> R1 (R1 z)++instance Associative Sum where+ associating = isoF to_ from_+ where+ to_ = \case+ InL x -> InL (InL x)+ InR (InL y) -> InL (InR y)+ InR (InR z) -> InR z+ from_ = \case+ InL (InL x) -> InL x+ InL (InR y) -> InR (InL y)+ InR z -> InR (InR z)++instance Associative These1 where+ associating = isoF to_ from_+ where+ to_ = \case+ This1 x -> This1 (This1 x )+ That1 (This1 y ) -> This1 (That1 y)+ That1 (That1 z) -> That1 z+ That1 (These1 y z) -> These1 (That1 y) z+ These1 x (This1 y ) -> This1 (These1 x y)+ These1 x (That1 z) -> These1 (This1 x ) z+ These1 x (These1 y z) -> These1 (These1 x y) z+ from_ = \case+ This1 (This1 x ) -> This1 x+ This1 (That1 y) -> That1 (This1 y )+ This1 (These1 x y) -> These1 x (This1 y )+ That1 z -> That1 (That1 z)+ These1 (This1 x ) z -> These1 x (That1 z)+ These1 (That1 y) z -> That1 (These1 y z)+ These1 (These1 x y) z -> These1 x (These1 y z)++instance Associative Void3 where+ associating = isoF coerce coerce++instance Associative Comp where+ associating = isoF to_ from_+ where+ to_ (x :>>= y) = (x :>>= (unComp . y)) :>>= id+ from_ ((x :>>= y) :>>= z) = x :>>= ((:>>= z) . y)++instance Semigroupoidal (:*:) where+ type SF (:*:) = NonEmptyF++ appendSF (NonEmptyF xs :*: NonEmptyF ys) = NonEmptyF (xs <> ys)+ matchSF x = case ys of+ L1 ~Proxy -> L1 y+ R1 zs -> R1 $ y :*: zs+ where+ y :*: ys = fromListF `hright` nonEmptyProd x++ consSF (x :*: NonEmptyF xs) = NonEmptyF $ x :| toList xs+ toSF (x :*: y ) = NonEmptyF $ x :| [y]++ biretract (x :*: y) = x <!> y+ binterpret f g (x :*: y) = f x <!> g y++instance Semigroupoidal Product where+ type SF Product = NonEmptyF++ appendSF (NonEmptyF xs `Pair` NonEmptyF ys) = NonEmptyF (xs <> ys)+ matchSF x = case ys of+ L1 ~Proxy -> L1 y+ R1 zs -> R1 $ Pair y zs+ where+ y :*: ys = fromListF `hright` nonEmptyProd x++ consSF (x `Pair` NonEmptyF xs) = NonEmptyF $ x :| toList xs+ toSF (x `Pair` y ) = NonEmptyF $ x :| [y]++ biretract (Pair x y) = x <!> y+ binterpret f g (Pair x y) = f x <!> g y++instance Semigroupoidal Day where+ type SF Day = Ap1++ appendSF (Day x y z) = z <$> x <.> y+ matchSF a = case fromAp `hright` ap1Day a of+ Day x y z -> case y of+ L1 (Identity y') -> L1 $ (`z` y') <$> x+ R1 ys -> R1 $ Day x ys z++ consSF (Day x y z) = Ap1 x $ flip z <$> toAp y+ toSF (Day x y z) = z <$> inject x <.> inject y++ biretract (Day x y z) = z <$> x <.> y+ binterpret f g (Day x y z) = z <$> f x <.> g y++instance Semigroupoidal (:+:) where+ type SF (:+:) = Step++ appendSF = \case+ L1 (Step i x) -> Step (i + 1) x+ R1 (Step i y) -> Step (i + 2) y+ matchSF = hright stepDown . stepDown++ consSF = stepUp . R1 . stepUp+ toSF = \case+ L1 x -> Step 1 x+ R1 y -> Step 2 y++ biretract = \case+ L1 x -> x+ R1 y -> y+ binterpret f g = \case+ L1 x -> f x+ R1 y -> g y++instance Semigroupoidal Sum where+ type SF Sum = Step++ appendSF = \case+ InL (Step i x) -> Step (i + 1) x+ InR (Step i y) -> Step (i + 2) y+ matchSF = hright (viewF sumSum . stepDown) . stepDown++ consSF = stepUp . R1 . stepUp . reviewF sumSum+ toSF = \case+ InL x -> Step 1 x+ InR y -> Step 2 y++ biretract = \case+ InR x -> x+ InL y -> y+ binterpret f g = \case+ InL x -> f x+ InR y -> g y++-- data TC f a = TCA (f a) Bool+-- | TCB (Maybe (f a)) (TC f a)+ -- sparse, non-empty list+ -- and the last item has a Bool+ -- aka sparse non-empty list tagged with a bool++-- | Ideally here 'SF' would be equivalent to 'Data.HBifunctor.Tensor.MF',+-- just like for ':+:'. This should be possible if we can write+-- a bijection. This bijection should be possible in theory --- but it has+-- not yet been implemented.+instance Semigroupoidal These1 where+ type SF These1 = ComposeT Flagged Steps++ appendSF s = ComposeT $ case s of+ This1 (ComposeT (Flagged _ q)) ->+ Flagged True q+ That1 (ComposeT (Flagged b q)) ->+ Flagged b (stepsUp (That1 q))+ These1 (ComposeT (Flagged a q)) (ComposeT (Flagged b r)) ->+ Flagged (a || b) (q <> r)+ matchSF (ComposeT (Flagged isImpure q)) = case stepsDown q of+ This1 x+ | isImpure -> R1 $ This1 x+ | otherwise -> L1 x+ That1 y -> R1 . That1 . ComposeT $ Flagged isImpure y+ These1 x y -> R1 . These1 x . ComposeT $ Flagged isImpure y++ consSF s = ComposeT $ case s of+ This1 x -> Flagged True (inject x)+ That1 (ComposeT (Flagged b y)) -> Flagged b (stepsUp (That1 y))+ These1 x (ComposeT (Flagged b y)) -> Flagged b (stepsUp (These1 x y))+ toSF s = ComposeT $ case s of+ This1 x -> Flagged True . Steps $ NEM.singleton 0 x+ That1 y -> Flagged False . Steps $ NEM.singleton 1 y+ These1 x y -> Flagged False . Steps $ NEM.fromDistinctAscList $ (0, x) :| [(1, y)]++ biretract = \case+ This1 x -> x+ That1 y -> y+ These1 x y -> x <!> y+ binterpret f g = \case+ This1 x -> f x+ That1 y -> g y+ These1 x y -> f x <!> g y++instance Semigroupoidal Comp where+ type SF Comp = Free1++ appendSF (x :>>= y) = x >>- y+ matchSF = matchFree1++ consSF (x :>>= y) = liftFree1 x >>- y+ toSF (x :>>= g) = liftFree1 x >>- inject . g++ biretract (x :>>= y) = x >>- y+ binterpret f g (x :>>= y) = f x >>- (g . y)++instance Associative Joker where+ associating = isoF (Joker . Joker . runJoker)+ (Joker . runJoker . runJoker)++instance Associative LeftF where+ associating = isoF (LeftF . LeftF . runLeftF)+ (LeftF . runLeftF . runLeftF)++instance Associative RightF where+ associating = isoF (RightF . runRightF . runRightF)+ (RightF . RightF . runRightF)++instance Semigroupoidal Joker where+ type SF Joker = Flagged++ appendSF (Joker (Flagged _ x)) = Flagged True x+ matchSF (Flagged False x) = L1 x+ matchSF (Flagged True x) = R1 $ Joker x++instance Semigroupoidal LeftF where+ type SF LeftF = Flagged++ appendSF = hbind (Flagged True) . runLeftF+ matchSF (Flagged False x) = L1 x+ matchSF (Flagged True x) = R1 $ LeftF x++ consSF = Flagged True . runLeftF+ toSF = Flagged True . runLeftF++ biretract = runLeftF+ binterpret f _ = f . runLeftF++instance Semigroupoidal RightF where+ type SF RightF = Step++ appendSF = stepUp . R1 . runRightF+ matchSF = hright RightF . stepDown++ consSF = stepUp . R1 . runRightF+ toSF = Step 1 . runRightF++ biretract = runRightF+ binterpret _ g = g . runRightF
+ src/Data/HBifunctor/Tensor.hs view
@@ -0,0 +1,790 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.HBifunctor.Tensor+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides tools for working with binary functor combinators.+--+-- "Data.Functor.HFunctor" deals with /single/ functor combinators+-- (transforming a single functor). This module provides tools for working+-- with combinators that combine and mix two functors "together".+--+-- The binary analog of 'HFunctor' is 'HBifunctor': we can map+-- a structure-transforming function over both of the transformed functors.+--+-- The binary analog of 'Interpret' is 'Monoidal' (and 'Tensor'). If your+-- combinator is an instance of 'Monoidal', it means that you can "squish"+-- both arguments together into an 'Interpret'. For example:+--+-- @+-- 'toMF' :: (f ':*:' f) a -> 'ListF' f a+-- 'toMF' :: 'Comp' f f a -> 'Free' f a+-- 'toMF' :: 'Day' f f a -> 'Ap' f a+-- @+module Data.HBifunctor.Tensor (+ -- * 'Tensor'+ Tensor(..)+ , rightIdentity+ , leftIdentity+ , sumLeftIdentity+ , sumRightIdentity+ , prodLeftIdentity+ , prodRightIdentity+ -- * 'Monoidal'+ , Monoidal(..)+ , CM+ , nilMF+ , consMF+ , unconsMF+ -- ** Utility+ , inL+ , inR+ , outL+ , outR+ , biretractT+ , binterpretT+ , prodOutL+ , prodOutR+ -- * 'Matchable'+ , Matchable(..)+ , splittingSF+ , matchingMF+ ) where++import Control.Applicative.Free+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Monad.Freer.Church+import Control.Monad.Trans.Compose+import Control.Natural+import Control.Natural.IsoF+import Data.Function+import Data.Functor.Apply.Free+import Data.Functor.Combinator.Unsafe+import Data.Functor.Day (Day(..))+import Data.Functor.Identity+import Data.Functor.Plus+import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.These+import Data.HBifunctor+import Data.HBifunctor.Associative+import Data.HFunctor+import Data.HFunctor.Internal+import Data.HFunctor.Interpret+import Data.Kind+import Data.List.NonEmpty (NonEmpty(..))+import Data.Proxy+import GHC.Generics hiding (C)+import qualified Data.Functor.Day as D+import qualified Data.Map.NonEmpty as NEM++-- | An 'Associative' 'HBifunctor' can be a 'Tensor' if there is some+-- identity @i@ where @t i f@ is equivalent to just @f@.+--+-- That is, "enhancing" @f@ with @t i@ does nothing.+--+-- The methods in this class provide us useful ways of navigating+-- a @'Tensor' t@ with respect to this property.+--+-- The 'Tensor' is essentially the 'HBifunctor' equivalent of 'Inject',+-- with 'intro1' and 'intro2' taking the place of 'inject'.+class Associative t => Tensor t where+ -- | The identity of @'Tensor' t@. If you "combine" @f@ with the+ -- identity, it leaves @f@ unchanged.+ --+ -- For example, the identity of ':*:' is 'Proxy'. This is because+ --+ -- @+ -- ('Proxy' :*: f) a+ -- @+ --+ -- is equivalent to just+ --+ -- @+ -- f a+ -- @+ --+ -- ':*:'-ing @f@ with 'Proxy' gives you no additional structure.+ --+ -- Another example:+ --+ -- @+ -- ('V1' ':+:' f) a+ -- @+ --+ -- is equivalent to just+ --+ -- @+ -- f a+ -- @+ --+ -- because the 'L1' case is unconstructable.+ type I t :: Type -> Type++ -- | Because @t f (I t)@ is equivalent to @f@, we can always "insert"+ -- @f@ into @t f (I t)@.+ --+ -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.+ intro1 :: f ~> t f (I t)++ -- | Because @t (I t) g@ is equivalent to @f@, we can always "insert"+ -- @g@ into @t (I t) g@.+ --+ -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.+ intro2 :: g ~> t (I t) g++ -- | Witnesses the property that @'I' t@ is the identity of @t@: @t+ -- f (I t)@ always leaves @f@ unchanged, so we can always just drop the+ -- @'I' t@.+ elim1 :: Functor f => t f (I t) ~> f++ -- | Witnesses the property that @'I' t@ is the identity of @t@: @t+ -- (I t) g@ always leaves @g@ unchanged, so we can always just drop the+ -- @'I' t@.+ elim2 :: Functor g => t (I t) g ~> g++ {-# MINIMAL intro1, intro2, elim1, elim2 #-}++-- | @f@ is isomorphic to @t f ('I' t)@: that is, @'I' t@ is the identity+-- of @t@, and leaves @f@ unchanged.+rightIdentity :: (Tensor t, Functor f) => f <~> t f (I t)+rightIdentity = isoF intro1 elim1++-- | @g@ is isomorphic to @t ('I' t) g@: that is, @'I' t@ is the identity+-- of @t@, and leaves @g@ unchanged.+leftIdentity :: (Tensor t, Functor g) => g <~> t (I t) g+leftIdentity = isoF intro2 elim2++-- | 'leftIdentity' ('intro1' and 'elim1') for ':+:' actually does not+-- require 'Functor'. This is the more general version.+sumLeftIdentity :: f <~> V1 :+: f+sumLeftIdentity = isoF R1 (absurd1 !*! id)++-- | 'rightIdentity' ('intro2' and 'elim2') for ':+:' actually does not+-- require 'Functor'. This is the more general version.+sumRightIdentity :: f <~> f :+: V1+sumRightIdentity = isoF L1 (id !*! absurd1)++-- | 'leftIdentity' ('intro1' and 'elim1') for ':*:' actually does not+-- require 'Functor'. This is the more general version.+prodLeftIdentity :: f <~> Proxy :*: f+prodLeftIdentity = isoF (Proxy :*:) (\case _ :*: y -> y)++-- | 'rightIdentity' ('intro2' and 'elim2') for ':*:' actually does not+-- require 'Functor'. This is the more general version.+prodRightIdentity :: g <~> g :*: Proxy+prodRightIdentity = isoF (:*: Proxy) (\case x :*: _ -> x)++-- | 'outL' for ':*:' actually does not require 'Functor'. This is the+-- more general version.+prodOutL :: f :*: g ~> f+prodOutL (x :*: _) = x++-- | 'outR' for ':*:' actually does not require 'Functor'. This is the+-- more general version.+prodOutR :: f :*: g ~> g+prodOutR (_ :*: y) = y++-- | A @'Monoidal' t@ is a 'Semigroupoidal', in that it provides some type+-- @'MF' t f@ that is equivalent to one of:+--+-- * @I a@ -- 0 times+-- * @f a@ -- 1 time+-- * @t f f a@ -- 2 times+-- * @t f (t f f) a@ -- 3 times+-- * @t f (t f (t f f)) a@ -- 4 times+-- * @t f (t f (t f (t f f))) a@ -- 5 times+-- * .. etc+--+-- The difference is that unlike @'SF' t@, @'MF' t@ has the "zero times"+-- value.+--+-- This typeclass lets you use a type like 'ListF' in terms of repeated+-- applications of ':*:', or 'Ap' in terms of repeated applications of+-- 'Day', or 'Free' in terms of repeated applications of 'Comp', etc.+--+-- For example, @f ':*:' f@ can be interpreted as "a free selection of two+-- @f@s", allowing you to specify "I have to @f@s that I can use". If you+-- want to specify "I want 0, 1, or many different @f@s that I can use",+-- you can use @'ListF' f@.+--+-- At the high level, the thing that 'Monoidal' adds to 'Semigroupoidal'+-- is 'inL', 'inR', and 'nilMF':+--+-- @+-- 'inL' :: f a -> t f g a+-- 'inR' :: g a -> t f g a+-- 'nilMF' :: I a -> MF t f a+-- @+--+-- which are like the 'HBifunctor' versions of 'inject': it lets you inject+-- an @f@ into @t f g@, so you can start doing useful mixing operations+-- with it. 'nilMF' lets you construct an "empty" @'MF' t@.+--+-- Also useful is:+--+-- @+-- 'toMF' :: t f f a -> MF t f a+-- @+--+-- Which converts a @t@ into its aggregate type 'MF'+class (Tensor t, Semigroupoidal t, Interpret (MF t)) => Monoidal t where+ -- | The "monoidal functor combinator" induced by @t@.+ --+ -- A value of type @MF t f a@ is /equivalent/ to one of:+ --+ -- * @I a@ -- zero fs+ -- * @f a@ -- one f+ -- * @t f f a@ -- two fs+ -- * @t f (t f f) a@ -- three fs+ -- * @t f (t f (t f f)) a@+ -- * @t f (t f (t f (t f f))) a@+ -- * .. etc+ --+ -- For example, for ':*:', we have 'ListF'. This is because:+ --+ -- @+ -- 'Proxy' ~ 'ListF' [] ~ 'nilMF' \@(':*:')+ -- x ~ ListF [x] ~ 'inject' x+ -- x :*: y ~ ListF [x,y] ~ 'toMF' (x :*: y)+ -- x :*: y :*: z ~ ListF [x,y,z]+ -- -- etc.+ -- @+ --+ -- You can create an "empty" one with 'nilMF', a "singleton" one with+ -- 'inject', or else one from a single @t f f@ with 'toMF'.+ type MF t :: (Type -> Type) -> Type -> Type+++ -- | If a @'MF' t f@ represents multiple applications of @t f@ to+ -- itself, then we can also "append" two @'MF' t f@s applied to+ -- themselves into one giant @'MF' t f@ containing all of the @t f@s.+ appendMF :: t (MF t f) (MF t f) ~> MF t f++ -- | Lets you convert an @'SF' t f@ into a single application of @f@ to+ -- @'MF' t f@.+ --+ -- Analogous to a function @'Data.List.NonEmpty.NonEmpty' a -> (a,+ -- [a])@+ --+ -- Note that this is not reversible in general unless we have+ -- @'Matchable' t@.+ splitSF :: SF t f ~> t f (MF t f)++ -- | An @'MF' t f@ is either empty, or a single application of @t@ to @f@+ -- and @MF t f@ (the "head" and "tail"). This witnesses that+ -- isomorphism.+ --+ -- To /use/ this property, see 'nilMF', 'consMF', and 'unconsMF'.+ splittingMF :: MF t f <~> I t :+: t f (MF t f)++ -- | Embed a direct application of @f@ to itself into a @'MF' t f@.+ toMF :: t f f ~> MF t f+ toMF = reviewF (splittingMF @t)+ . R1+ . hright (inject @(MF t))++ -- | @'SF' t f@ is "one or more @f@s", and @'MF t f@ is "zero or more+ -- @f@s". This function lets us convert from one to the other.+ --+ -- This is analogous to a function @'Data.List.NonEmpty.NonEmpty' a ->+ -- [a]@.+ --+ -- Note that because @t@ is not inferrable from the input or output+ -- type, you should call this using /-XTypeApplications/:+ --+ -- @+ -- 'fromSF' \@(':*:') :: 'NonEmptyF' f a -> 'ListF' f a+ -- fromSF \@'Comp' :: 'Free1' f a -> 'Free' f a+ -- @+ fromSF :: SF t f ~> MF t f+ fromSF = reviewF (splittingMF @t) . R1 . splitSF @t++ -- | If we have an @'I' t@, we can generate an @f@ based on how it+ -- interacts with @t@.+ --+ -- Specialized (and simplified), this type is:+ --+ -- @+ -- 'pureT' \@'Day' :: 'Applicative' f => 'Identity' a -> f a -- 'pure'+ -- pureT \@'Comp' :: 'Monad' f => Identity a -> f a -- 'return'+ -- pureT \@(':*:') :: 'Plus' f => 'Proxy' a -> f a -- 'zero'+ -- @+ --+ -- Note that because @t@ appears nowhere in the input or output types,+ -- you must always use this with explicit type application syntax (like+ -- @pureT \@Day@)+ pureT :: CM t f => I t ~> f+ pureT = retract . reviewF (splittingMF @t) . L1++ -- | If we have a constraint on the 'Monoidal' satisfied, it should+ -- also imply the constraint on the 'Semigroupoidal'.+ --+ -- This is basically saying that @'C' ('SF' t)@ should be a superclass+ -- of @'C' ('MF' t)@.+ --+ -- For example, for ':*:', this type signature says that 'Alt' is+ -- a superclass of 'Plus', so whenever you have 'Plus', you should+ -- always also have 'Alt'.+ --+ -- For 'Day', this type signature says that 'Apply' is a superclass of+ -- 'Applicative', so whenever you have 'Applicative', you should always+ -- also have 'Apply'.+ --+ -- This is necessary because in the current class hierarchy, 'Apply'+ -- isn't a true superclass of 'Applicative'. 'upgradeC' basically+ -- "imbues" @f@ with an 'Apply' instance based on its 'Applicative'+ -- instance, so things can be easier to use.+ --+ -- For example, let's say I have a type @Parser@ that is an+ -- 'Applicative' instance, but the source library does not define an+ -- 'Apply' instance. I cannot use 'biretract' or 'binterpret' with it,+ -- even though I should be able to, because they require 'Apply'.+ --+ -- That is:+ --+ -- @+ -- 'biretract' :: 'Day' Parser Parser a -> Parser a+ -- @+ --+ -- is a type error, because it requires @'Apply' Parser@.+ --+ -- But, if we know that @Parser@ has an 'Applicative' instance, we can+ -- use:+ --+ -- @+ -- 'upgradeC' @'Day' ('Proxy' \@Parser) 'biretract'+ -- :: Day Parser Parser a -> a+ -- @+ --+ -- and this will now typecheck properly.+ --+ -- Ideally, @Parser@ would also have an 'Apply' instance. But we+ -- cannot control this if an external library defines @Parser@.+ --+ -- (Alternatively you can just use 'biretractT'.)+ --+ -- Note that you should only use this if @f@ doesn't already have the+ -- 'SF' constraint. If it does, this could lead to conflicting+ -- instances. Only use this with /specific/, concrete @f@s. Otherwise+ -- this is unsafe and can possibly break coherence guarantees.+ --+ -- The @proxy@ argument can be provided using something like @'Proxy'+ -- \@f@, to specify which @f@ you want to upgrade.+ upgradeC :: CM t f => proxy f -> (CS t f => r) -> r++ {-# MINIMAL appendMF, splitSF, splittingMF, upgradeC #-}++-- | Convenient alias for the constraint required for 'inL', 'inR',+-- 'pureT', etc.+--+-- It's usually a constraint on the target/result context of interpretation+-- that allows you to "exit" or "run" a @'Monoidal' t@.+type CM t = C (MF t)++-- | Create the "empty 'MF'@.+--+-- If @'MF' t f@ represents multiple applications of @t f@ with+-- itself, then @nilMF@ gives us "zero applications of @f@".+--+-- Note that @t@ cannot be inferred from the input or output type of+-- 'nilMF', so this function must always be called with -XTypeApplications:+--+-- @+-- 'nilMF' \@'Day' :: 'Identity' '~>' 'Ap' f+-- nilMF \@'Comp' :: Identity ~> 'Free' f+-- nilMF \@(':*:') :: 'Proxy' ~> 'ListF' f+-- @+nilMF :: forall t f. Monoidal t => I t ~> MF t f+nilMF = reviewF (splittingMF @t) . L1++-- | Lets us "cons" an application of @f@ to the front of an @'MF' t f@.+consMF :: Monoidal t => t f (MF t f) ~> MF t f+consMF = reviewF splittingMF . R1++-- | "Pattern match" on an @'MF' t@+--+-- An @'MF' t f@ is either empty, or a single application of @t@ to @f@+-- and @MF t f@ (the "head" and "tail")+--+-- This is analogous to the function @'Data.List.uncons' :: [a] -> Maybe+-- (a, [a])@.+unconsMF :: Monoidal t => MF t f ~> I t :+: t f (MF t f)+unconsMF = viewF splittingMF++-- | Convenient wrapper over 'intro1' that lets us introduce an arbitrary+-- functor @g@ to the right of an @f@.+--+-- You can think of this as an 'HBifunctor' analogue of 'inject'.+inL+ :: forall t f g. (Monoidal t, CM t g)+ => f ~> t f g+inL = hright (pureT @t) . intro1++-- | Convenient wrapper over 'intro2' that lets us introduce an arbitrary+-- functor @f@ to the right of a @g@.+--+-- You can think of this as an 'HBifunctor' analogue of 'inject'.+inR+ :: forall t f g. (Monoidal t, CM t f)+ => g ~> t f g+inR = hleft (pureT @t) . intro2++-- | Convenient wrapper over 'elim1' that lets us drop one of the arguments+-- of a 'Tensor' for free, without requiring any extra constraints (like+-- for 'binterpret').+--+-- See 'prodOutL' for a version that does not require @'Functor' f@,+-- specifically for ':*:'.+outL+ :: (Tensor t, I t ~ Proxy, Functor f)+ => t f g ~> f+outL = elim1 . hright absorb++-- | Convenient wrapper over 'elim2' that lets us drop one of the arguments+-- of a 'Tensor' for free, without requiring any constraints (like for+-- 'binterpret').+--+-- See 'prodOutR' for a version that does not require @'Functor' g@,+-- specifically for ':*:'.+outR+ :: (Tensor t, I t ~ Proxy, Functor g)+ => t f g ~> g+outR = elim2 . hleft absorb++-- | This is 'biretract', but taking a @'C' ('MF' t)@ constraint instead of+-- a @'C' ('SF' t)@ constraint. For example, for 'Day', it takes an+-- 'Applicative' constraint instead of an 'Apply' constraint.+--+-- In an ideal world, this would be not necessary, and we can use+-- 'biretract'. However, sometimes @'C' ('MF' t)@ is not an actual+-- subclass of @'C' ('SF' t)@ (like 'Apply' and 'Applicative'), even though+-- it should technically always be so.+--+-- Note that you should only use this if @f@ doesn't already have the 'SF'+-- constraint (for example, for 'Day', if @f@ already has an 'Apply'+-- instance). If it does, this could lead to conflicting instances. If+-- @f@ already has the 'SF' instance, just use 'biretract' directly. Only+-- use this with /specific/, concrete @f@s.+biretractT :: forall t f. (Monoidal t, CM t f) => t f f ~> f+biretractT = upgradeC @t (Proxy @f)+ biretract++-- | This is 'binterpret', but taking a @'C' ('MF' t)@ constraint instead of+-- a @'C' ('SF' t)@ constraint. For example, for 'Day', it takes an+-- 'Applicative' constraint instead of an 'Apply' constraint.+--+-- In an ideal world, this would be not necessary, and we can use+-- 'biretract'. However, sometimes @'C' ('MF' t)@ is not an actual+-- subclass of @'C' ('SF' t)@ (like 'Apply' and 'Applicative'), even though+-- it should technically always be so.+--+-- Note that you should only use this if @f@ doesn't already have the 'SF'+-- constraint (for example, for 'Day', if @f@ already has an 'Apply'+-- instance). If it does, this could lead to conflicting instances. If+-- @f@ already has the 'SF' instance, just use 'biretract' directly. Only+-- use this with /specific/, concrete @f@s.+binterpretT+ :: forall t f g h. (Monoidal t, CM t h)+ => f ~> h+ -> g ~> h+ -> t f g ~> h+binterpretT f g = upgradeC @t (Proxy @h) $+ binterpret f g++-- | For some @t@, we have the ability to "statically analyze" the @'MF' t@+-- and pattern match and manipulate the structure without ever+-- interpreting or retracting. These are 'Matchable'.+class Monoidal t => Matchable t where+ -- | The inverse of 'splitSF'. A consing of @f@ to @'MF' t f@ is+ -- non-empty, so it can be represented as an @'SF' t f@.+ --+ -- This is analogous to a function @'uncurry' ('Data.List.NonEmpty.:|')+ -- :: (a, [a]) -> 'Data.List.NonEmpty.NonEmpty' a@.+ unsplitSF :: t f (MF t f) ~> SF t f++ -- | "Pattern match" on an @'MF' t f@: it is either empty, or it is+ -- non-empty (and so can be an @'SF' t f@).+ --+ -- This is analgous to a function @'Data.List.NonEmpty.nonEmpty' :: [a]+ -- -> Maybe ('Data.List.NonEmpty.NonEmpty' a)@.+ --+ -- Note that because @t@ cannot be inferred from the input or output+ -- type, you should use this with /-XTypeApplications/:+ --+ -- @+ -- 'matchMF' \@'Day' :: 'Ap' f a -> ('Identity' :+: 'Ap1' f) a+ -- @+ matchMF :: MF t f ~> I t :+: SF t f++-- | An @'SF' t f@ is isomorphic to an @f@ consed with an @'MF' t f@, like+-- how a @'Data.List.NonEmpty.NonEmpty' a@ is isomorphic to @(a, [a])@.+splittingSF :: Matchable t => SF t f <~> t f (MF t f)+splittingSF = isoF splitSF unsplitSF++-- | An @'MF' t f@ is isomorphic to either the empty case (@'I' t@) or the+-- non-empty case (@'SF' t f@), like how @[a]@ is isomorphic to @'Maybe'+-- ('Data.List.NonEmpty.NonEmpty' a)@.+matchingMF :: forall t f. Matchable t => MF t f <~> I t :+: SF t f+matchingMF = isoF (matchMF @t) (nilMF @t !*! fromSF @t)++instance Tensor (:*:) where+ type I (:*:) = Proxy++ intro1 = (:*: Proxy)+ intro2 = (Proxy :*:)++ elim1 (x :*: ~Proxy) = x+ elim2 (~Proxy :*: y ) = y++instance Tensor Product where+ type I Product = Proxy++ intro1 = (`Pair` Proxy)+ intro2 = (Proxy `Pair`)++ elim1 (Pair x ~Proxy) = x+ elim2 (Pair ~Proxy y) = y++instance Tensor Day where+ type I Day = Identity++ intro1 = D.intro2+ intro2 = D.intro1+ elim1 = D.elim2+ elim2 = D.elim1++instance Tensor (:+:) where+ type I (:+:) = V1++ intro1 = L1+ intro2 = R1++ elim1 = \case+ L1 x -> x+ R1 y -> absurd1 y+ elim2 = \case+ L1 x -> absurd1 x+ R1 y -> y++instance Tensor Sum where+ type I Sum = V1++ intro1 = InL+ intro2 = InR++ elim1 = \case+ InL x -> x+ InR y -> absurd1 y+ elim2 = \case+ InL x -> absurd1 x+ InR y -> y++instance Tensor These1 where+ type I These1 = V1++ intro1 = This1+ intro2 = That1+ elim1 = \case+ This1 x -> x+ That1 y -> absurd1 y+ These1 _ y -> absurd1 y+ elim2 = \case+ This1 x -> absurd1 x+ That1 y -> y+ These1 x _ -> absurd1 x++instance Tensor Comp where+ type I Comp = Identity++ intro1 = (:>>= Identity)+ intro2 = (Identity () :>>=) . const++ elim1 (x :>>= y) = runIdentity . y <$> x+ elim2 (x :>>= y) = y (runIdentity x)++instance Monoidal (:*:) where+ type MF (:*:) = ListF++ appendMF (ListF xs :*: ListF ys) = ListF (xs ++ ys)+ splitSF = nonEmptyProd+ splittingMF = isoF to_ from_+ where+ to_ = \case+ ListF [] -> L1 Proxy+ ListF (x:xs) -> R1 (x :*: ListF xs)+ from_ = \case+ L1 ~Proxy -> ListF []+ R1 (x :*: ListF xs) -> ListF (x:xs)++ toMF (x :*: y) = ListF [x, y]+ pureT _ = zero++ upgradeC _ x = x++instance Monoidal Product where+ type MF Product = ListF++ appendMF (ListF xs `Pair` ListF ys) = ListF (xs ++ ys)+ splitSF = viewF prodProd . nonEmptyProd+ splittingMF = isoF to_ from_+ where+ to_ = \case+ ListF [] -> L1 Proxy+ ListF (x:xs) -> R1 (x `Pair` ListF xs)+ from_ = \case+ L1 ~Proxy -> ListF []+ R1 (x `Pair` ListF xs) -> ListF (x:xs)++ toMF (Pair x y) = ListF [x, y]+ pureT _ = zero++ upgradeC _ x = x++instance Monoidal Day where+ type MF Day = Ap++ appendMF (Day x y z) = z <$> x <*> y+ splitSF = ap1Day+ splittingMF = isoF to_ from_+ where+ to_ = \case+ Pure x -> L1 (Identity x)+ Ap x xs -> R1 (Day x xs (&))+ from_ = \case+ L1 (Identity x) -> Pure x+ R1 (Day x xs f) -> Ap x (flip f <$> xs)++ toMF (Day x y z) = z <$> liftAp x <*> liftAp y+ pureT = generalize++ upgradeC = unsafeApply++instance Monoidal (:+:) where+ type MF (:+:) = Step++ appendMF = id !*! stepUp . R1+ splitSF = stepDown+ splittingMF = stepping . sumLeftIdentity++ toMF = \case+ L1 x -> Step 0 x+ R1 x -> Step 1 x+ pureT = absurd1++ upgradeC _ x = x++instance Monoidal Sum where+ type MF Sum = Step++ appendMF = id !*! stepUp . R1+ splitSF = viewF sumSum . stepDown+ splittingMF = stepping+ . sumLeftIdentity+ . overHBifunctor id sumSum++ toMF = \case+ InL x -> Step 0 x+ InR x -> Step 1 x+ pureT = absurd1++ upgradeC _ x = x++instance Monoidal These1 where+ type MF These1 = Steps++ appendMF = \case+ This1 x -> x+ That1 y -> stepsUp . That1 $ y+ These1 x y -> x <> y+ splitSF = stepsDown . flaggedVal . getComposeT+ splittingMF = steppings . sumLeftIdentity++ toMF = \case+ This1 x -> Steps $ NEM.singleton 0 x+ That1 y -> Steps $ NEM.singleton 1 y+ These1 x y -> Steps $ NEM.fromDistinctAscList ((0, x) :| [(1, y)])+ pureT = absurd1++ upgradeC _ x = x++instance Monoidal Comp where+ type MF Comp = Free++ appendMF (x :>>= y) = x >>= y+ splitSF = free1Comp+ splittingMF = isoF to_ from_+ where+ to_ :: Free f ~> Identity :+: Comp f (Free f)+ to_ = foldFree' (L1 . Identity) $ \y n -> R1 $+ y :>>= (from_ . n)+ from_ :: Identity :+: Comp f (Free f) ~> Free f+ from_ = generalize+ !*! (\case x :>>= f -> liftFree x >>= f)++ toMF (x :>>= y) = liftFree x >>= (inject . y)+ pureT = generalize++ upgradeC = unsafeBind++instance Matchable (:*:) where+ unsplitSF = ProdNonEmpty+ matchMF = fromListF++instance Matchable Product where+ unsplitSF = ProdNonEmpty . reviewF prodProd+ matchMF = fromListF++instance Matchable Day where+ unsplitSF = DayAp1+ matchMF = fromAp++instance Matchable (:+:) where+ unsplitSF = stepUp+ matchMF = R1++instance Matchable Sum where+ unsplitSF = stepUp . reviewF sumSum+ matchMF = R1++-- We can't write this until we get an isomorphism between MF These1 and SF These1+-- instance Matchable These1 where+-- unsplitSF = stepsUp+-- matchMF = R1
+ src/Data/HFunctor.hs view
@@ -0,0 +1,602 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Data.HFunctor+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides abstractions for working with unary functor combinators.+--+-- Principally, it defines the 'HFunctor' itself, as well as some classes+-- that expose extra functionality that some 'HFunctor's have ('Inject' and+-- 'HBind').+--+-- See "Data.HFunctor.Interpret" for tools to use 'HFunctor's as functor+-- combinators that can represent interpretable schemas, and+-- "Data.HBifunctor" for an abstraction over /binary/ functor combinators.+module Data.HFunctor (+ HFunctor(..)+ , overHFunctor+ , Inject(..)+ , HBind(..)+ -- * Simple instances+ , ProxyF(..)+ , ConstF(..)+ -- * 'HFunctor' Combinators+ , HLift(..), retractHLift+ , HFree(..), foldHFree, retractHFree+ ) where++import Control.Applicative.Backwards+import Control.Applicative.Free+import Control.Applicative.Lift+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Comonad.Trans.Env+import Control.Monad.Freer.Church+import Control.Monad.Reader+import Control.Monad.Trans.Compose+import Control.Monad.Trans.Identity+import Control.Natural+import Control.Natural.IsoF+import Data.Coerce+import Data.Data+import Data.Deriving+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Coyoneda+import Data.Functor.Plus+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.Functor.These+import Data.HFunctor.Internal+import Data.List.NonEmpty (NonEmpty(..))+import Data.Pointed+import Data.Semigroup.Foldable+import GHC.Generics+import qualified Control.Alternative.Free as Alt+import qualified Control.Applicative.Free.Fast as FAF+import qualified Control.Applicative.Free.Final as FA+import qualified Data.Map as M+import qualified Data.Map.NonEmpty as NEM++-- | Lift an isomorphism over an 'HFunctor'.+--+-- Essentailly, if @f@ and @g@ are isomorphic, then so are @t f@ and @t g@.+overHFunctor+ :: HFunctor t+ => f <~> g+ -> t f <~> t g+overHFunctor f = isoF (hmap (viewF f)) (hmap (reviewF f))++-- | The functor combinator that forgets all structure in the input.+-- Ignores the input structure and stores no information.+--+-- Acts like the "zero" with respect to functor combinator composition.+--+-- @+-- 'Control.Monad.Trans.Compose.ComposeT' ProxyF f ~ ProxyF+-- 'Control.Monad.Trans.Compose.ComposeT' f ProxyF ~ ProxyF+-- @+--+-- It can be 'inject'ed into (losing all information), but it is impossible+-- to ever 'Data.HFunctor.Interpret.retract' or+-- 'Data.HFunctor.Interpret.interpret' it.+--+-- This is essentially @'ConstF' ()@.+data ProxyF f a = ProxyF+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''ProxyF+deriveRead1 ''ProxyF+deriveEq1 ''ProxyF+deriveOrd1 ''ProxyF++instance HFunctor ProxyF where+ hmap _ = coerce++-- | Functor combinator that forgets all structure on the input, and+-- instead stores a value of type @e@.+--+-- Like 'ProxyF', acts like a "zero" with functor combinator composition.+--+-- It can be 'inject'ed into (losing all information), but it is impossible+-- to ever 'Data.HFunctor.Interpret.retract' or+-- 'Data.HFunctor.Interpret.interpret' it.+data ConstF e f a = ConstF { getConstF :: e }+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)++deriveShow1 ''ConstF+deriveRead1 ''ConstF+deriveEq1 ''ConstF+deriveOrd1 ''ConstF++instance HFunctor (ConstF e) where+ hmap _ = coerce++-- | An "'HFunctor' combinator" that enhances an 'HFunctor' with the+-- ability to hold a single @f a@. This is the higher-order analogue of+-- 'Control.Applicative.Lift.Lift'.+--+-- You can think of it as a free 'Inject' for any @f@.+--+-- Note that @'HLift' 'IdentityT'@ is equivalent to @'EnvT'+-- 'Data.Semigroup.Any'@.+data HLift t f a = HPure (f a)+ | HOther (t f a)+ deriving Functor++instance (Show1 (t f), Show1 f) => Show1 (HLift t f) where+ liftShowsPrec sp sl d = \case+ HPure x -> showsUnaryWith (liftShowsPrec sp sl) "HPure" d x+ HOther x -> showsUnaryWith (liftShowsPrec sp sl) "HOther" d x++deriving instance (Show (f a), Show (t f a)) => Show (HLift t f a)+deriving instance (Read (f a), Read (t f a)) => Read (HLift t f a)+deriving instance (Eq (f a), Eq (t f a)) => Eq (HLift t f a)+deriving instance (Ord (f a), Ord (t f a)) => Ord (HLift t f a)++instance (Eq1 (t f), Eq1 f) => Eq1 (HLift t f) where+ liftEq eq = \case+ HPure x -> \case+ HPure y -> liftEq eq x y+ HOther _ -> False+ HOther x -> \case+ HPure _ -> False+ HOther y -> liftEq eq x y++instance (Ord1 (t f), Ord1 f) => Ord1 (HLift t f) where+ liftCompare c = \case+ HPure x -> \case+ HPure y -> liftCompare c x y+ HOther _ -> LT+ HOther x -> \case+ HPure _ -> GT+ HOther y -> liftCompare c x y++instance HFunctor t => HFunctor (HLift t) where+ hmap f = \case+ HPure x -> HPure (f x)+ HOther x -> HOther (hmap f x)++-- | A higher-level 'Data.HFunctor.Interpret.retract' to get a @t f a@ back+-- out of an @'HLift' t f a@, provided @t@ is an instance of 'Inject'.+--+-- This witnesses the fact that 'HLift' is the "Free 'Inject'".+retractHLift+ :: Inject t+ => HLift t f a+ -> t f a+retractHLift = \case+ HPure x -> inject x+ HOther x -> x++-- | An "'HFunctor' combinator" that turns an 'HFunctor' into potentially+-- infinite nestings of that 'HFunctor'.+--+-- An @'HFree' t f a@ is either @f a@, @t f a@, @t (t f) a@, @t (t (t f))+-- a@, etc.+--+-- This effectively turns @t@ into a tree with @t@ branches.+--+-- One particularly useful usage is with 'MapF'. For example if you had+-- a data type representing a command line command parser:+--+-- @+-- data Command a+-- @+--+-- You could represent "many possible named commands" using+--+-- @+-- type Commands = 'MapF' 'String' Command+-- @+--+-- And you can represent multiple /nested/ named commands using:+--+-- @+-- type NestedCommands = 'HFree' ('MapF' 'String')+-- @+--+-- This has an 'Data.HFunctor.Interpret.Interpret' instance, but it can be+-- more useful to use via direct pattern matching, or through+--+-- @+-- 'foldHFree'+-- :: 'HBifunctor' t+-- => f '~>' g+-- -> t g ~> g+-- -> HFree t f ~> g+-- @+--+-- which requires no extra constriant on @g@, and lets you consider each+-- branch separately.+--+-- This can be considered the higher-oder analogue of+-- 'Control.Monad.Free.Free'; it is the free 'HBind' for any @'HFunctor'+-- t@.+--+-- Note that @'HFree' 'IdentityT'@ is equivalent to 'Step'.+data HFree t f a = HReturn (f a)+ | HJoin (t (HFree t f) a)++deriving instance (Functor f, Functor (t (HFree t f))) => Functor (HFree t f)++-- | Recursively fold down an 'HFree' into a single @g@ result, by handling+-- each branch. Can be more useful than+-- 'Data.HFunctor.Interpret.interpret' because it allows you to treat each+-- branch separately, and also does not require any constraint on @g@.+--+-- This is the catamorphism on 'HFree'.+foldHFree+ :: forall t f g. HFunctor t+ => (f ~> g)+ -> (t g ~> g)+ -> (HFree t f ~> g)+foldHFree f g = go+ where+ go :: HFree t f ~> g+ go (HReturn x) = f x+ go (HJoin x) = g (hmap go x)++-- | A higher-level 'Data.HFunctor.Interpret.retract' to get a @t f a@ back+-- out of an @'HFree' t f a@, provided @t@ is an instance of 'Bind'.+--+-- This witnesses the fact that 'HFree' is the "Free 'Bind'".+retractHFree+ :: HBind t+ => HFree t f a+ -> t f a+retractHFree = \case+ HReturn x -> inject x+ HJoin x -> hbind retractHFree x++instance (Show1 (t (HFree t f)), Show1 f) => Show1 (HFree t f) where+ liftShowsPrec sp sl d = \case+ HReturn x -> showsUnaryWith (liftShowsPrec sp sl) "HReturn" d x+ HJoin x -> showsUnaryWith (liftShowsPrec sp sl) "HJoin" d x++instance (Show1 (t (HFree t f)), Show1 f, Show a) => Show (HFree t f a) where+ showsPrec = liftShowsPrec showsPrec showList++instance HFunctor t => HFunctor (HFree t) where+ hmap :: forall f g. (f ~> g) -> HFree t f ~> HFree t g+ hmap f = go+ where+ go :: HFree t f ~> HFree t g+ go = \case+ HReturn x -> HReturn (f x)+ HJoin x -> HJoin (hmap go x)++-- | A typeclass for 'HFunctor's where you can "inject" an @f a@ into a @t+-- f a@:+--+-- @+-- 'inject' :: f a -> t f a+-- @+--+-- If you think of @t f a@ as an "enhanced @f@", then 'inject' allows you+-- to use an @f@ as its enhanced form.+--+-- With the exception of directly pattern matching on the result, 'inject'+-- itself is not too useful in the general case without+-- 'Data.HFunctor.Interpret.Interpret' to allow us to interpret or retrieve+-- back the @f@.+class HFunctor t => Inject t where+ -- | Lift from @f@ into the enhanced @t f@ structure. Analogous to+ -- 'lift' from 'MonadTrans'.+ --+ -- Note that this lets us "lift" a @f a@; if you want to lift an @a@+ -- with @a -> t f a@, check if @t f@ is an instance of 'Applicative' or+ -- 'Pointed'.+ inject :: f ~> t f++ {-# MINIMAL inject #-}++-- | 'HBind' is effectively a "higher-order 'Monad'", in the sense that+-- 'HFunctor' is a "higher-order 'Functor'".+--+-- It can be considered a typeclass for 'HFunctor's that you can bind+-- continuations to, nautral/universal over all @f@/functors. They work+-- "for all functors" you lift, without requiring any constraints.+--+-- It is very similar to 'Data.HFunctor.Interpret.Interpret', except+-- 'Data.HFunctor.Interpret.Interpret' has the ability to constrain the+-- contexts to some typeclass.+--+-- The main law is that binding 'inject' should leave things unchanged:+--+-- @+-- 'hbind' 'inject' == 'id'+-- @+--+-- But 'hbind' should also be associatiatve, in a way that makes+--+-- @+-- 'hjoin' . hjoin+-- = hjoin . 'hmap' hjoin+-- @+--+-- That is, squishing a @t (t (t f)) a@ into a @t f a@ can be done "inside"+-- first, then "outside", or "outside" first, then "inside".+--+-- Note that these laws are different from the+-- 'Data.HFunctor.Interpret.Interpret' laws, so we often have instances+-- where 'hbind' and 'Data.HFunctor.Interpret.interpret' (though they both+-- may typecheck) produce different behavior.+--+-- This class is similar to 'Control.Monad.Morph.MMonad' from+-- "Control.Monad.Morph", but instances must work without a 'Monad' constraint.+class Inject t => HBind t where+ -- | Bind a continuation to a @t f@ into some context @g@.+ hbind :: (f ~> t g) -> t f ~> t g+ hbind f = hjoin . hmap f++ -- | Collapse a nested @t (t f)@ into a single @t f@.+ hjoin :: t (t f) ~> t f+ hjoin = hbind id+ {-# MINIMAL hbind | hjoin #-}++instance Inject Coyoneda where+ inject = liftCoyoneda++instance Inject Ap where+ inject = liftAp++instance Inject ListF where+ inject = ListF . (:[])++instance Inject NonEmptyF where+ inject = NonEmptyF . (:| [])++instance Inject MaybeF where+ inject = MaybeF . Just++-- | Injects into a singleton map at 'mempty'.+instance Monoid k => Inject (NEMapF k) where+ inject = NEMapF . NEM.singleton mempty++-- | Injects into a singleton map at 'mempty'.+instance Monoid k => Inject (MapF k) where+ inject = MapF . M.singleton mempty++-- | Injects with 0.+--+-- Equivalent to instance for @'EnvT' ('Data.Semigroup.Sum'+-- 'Numeric.Natural.Natural')@.+instance Inject Step where+ inject = Step 0++-- | Injects into a singleton map at 0; same behavior as @'NEMapF'+-- ('Data.Semigroup.Sum' 'Numeric.Natural.Natural')@.+instance Inject Steps where+ inject = Steps . NEM.singleton 0++-- | Injects with 'False'.+--+-- Equivalent to instance for @'EnvT' 'Data.Semigroup.Any'@ and @'HLift'+-- 'IdentityT'@.+instance Inject Flagged where+ inject = Flagged False++instance Inject (These1 f) where+ inject = That1++instance Applicative f => Inject (Comp f) where+ inject x = pure () :>>= const x++instance Applicative f => Inject ((:.:) f) where+ inject x = Comp1 $ pure x++-- | Only uses 'zero'+instance Plus f => Inject ((:*:) f) where+ inject = (zero :*:)++-- | Only uses 'zero'+instance Plus f => Inject (Product f) where+ inject = Pair zero++instance Inject ((:+:) f) where+ inject = R1++instance Inject (Sum f) where+ inject = InR++instance Inject (M1 i c) where+ inject = M1++instance Inject Alt.Alt where+ inject = Alt.liftAlt++instance Inject Free where+ inject = liftFree++instance Inject Free1 where+ inject = liftFree1++instance Inject FA.Ap where+ inject = FA.liftAp++instance Inject FAF.Ap where+ inject = FAF.liftAp++instance Inject IdentityT where+ inject = coerce++instance Inject Lift where+ inject = Other++instance Inject MaybeApply where+ inject = MaybeApply . Left++instance Inject Backwards where+ inject = Backwards++instance Inject WrappedApplicative where+ inject = WrapApplicative++instance Inject (ReaderT r) where+ inject = ReaderT . const++instance Monoid e => Inject (EnvT e) where+ inject = EnvT mempty++instance Inject Reverse where+ inject = Reverse++instance Inject ProxyF where+ inject _ = ProxyF++instance Monoid e => Inject (ConstF e) where+ inject _ = ConstF mempty++instance (Inject s, Inject t) => Inject (ComposeT s t) where+ inject = ComposeT . inject . inject++instance HFunctor t => Inject (HLift t) where+ inject = HPure++-- | 'HFree' is the "free 'HBind' and 'Inject'" for any 'HFunctor'+instance HFunctor t => Inject (HFree t) where+ inject = HReturn++instance HBind Coyoneda where+ hbind f (Coyoneda g x) = g <$> f x++instance HBind Ap where+ hbind = runAp++instance HBind ListF where+ hbind f = foldMap f . runListF++instance HBind NonEmptyF where+ hbind f = foldMap1 f . runNonEmptyF++instance HBind MaybeF where+ hbind f = foldMap f . runMaybeF++-- | Equivalent to instance for @'EnvT' ('Data.Semigroup.Sum'+-- 'Numeric.Natural.Natural')@.+instance HBind Step where+ hbind f (Step n x) = Step (n + m) y+ where+ Step m y = f x++-- | Equivalent to instance for @'EnvT' 'Data.Semigroup.Any'@ and @'HLift'+-- 'IdentityT'@.+instance HBind Flagged where+ hbind f (Flagged p x) = Flagged (p || q) y+ where+ Flagged q y = f x++instance Alt f => HBind (These1 f) where+ hbind f = \case+ This1 x -> This1 x+ That1 y -> f y+ These1 x y -> case f y of+ This1 x' -> This1 (x <!> x')+ That1 y' -> That1 y'+ These1 x' y' -> These1 (x <!> x') y'++instance Plus f => HBind ((:*:) f) where+ hbind f (x :*: y) = (x <!> x') :*: y'+ where+ x' :*: y' = f y++instance Plus f => HBind (Product f) where+ hbind f (Pair x y) = Pair (x <!> x') y'+ where+ Pair x' y' = f y++instance HBind ((:+:) f) where+ hbind f = \case+ L1 x -> L1 x+ R1 y -> f y++instance HBind (Sum f) where+ hbind f = \case+ InL x -> InL x+ InR y -> f y++instance HBind (M1 i c) where+ hbind f (M1 x) = f x++instance HBind Alt.Alt where+ hbind = Alt.runAlt++instance HBind Free where+ hbind = interpretFree++instance HBind Free1 where+ hbind = interpretFree1++instance HBind FA.Ap where+ hbind = FA.runAp++instance HBind FAF.Ap where+ hbind = FAF.runAp++instance HBind IdentityT where+ hbind f = f . runIdentityT++instance HBind Lift where+ hbind = elimLift point++instance HBind MaybeApply where+ hbind f = either f point . runMaybeApply++instance HBind Backwards where+ hbind f = f . forwards++instance HBind WrappedApplicative where+ hbind f = f . unwrapApplicative++instance HBind Reverse where+ hbind f = f . getReverse++instance HBind ProxyF where+ hbind _ = coerce++-- | Combines the accumulators, Writer-style+instance Monoid e => HBind (EnvT e) where+ hbind f (EnvT e x) = EnvT (e <> e') y+ where+ EnvT e' y = f x++instance (HBind t, Inject t) => HBind (HLift t) where+ hbind f = \case+ HPure x -> f x+ HOther x -> HOther $ (`hbind` x) $ \y -> case f y of+ HPure z -> inject z+ HOther z -> z++-- | 'HFree' is the "free 'HBind'" for any 'HFunctor'+instance HFunctor t => HBind (HFree t) where+ hbind f = \case+ HReturn x -> f x+ HJoin x -> HJoin $ hmap (hbind f) x
+ src/Data/HFunctor/Chain.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.HFunctor.Chain+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides an 'Interpret'able data type of "linked list of+-- tensor applications".+--+-- The type @'Chain' t@, for any @'Monoidal' t@, is meant to be the same as+-- @'MF' t@ (the monoidal functor combinator for @t@), and represents "zero+-- or more" applications of @f@ to @t@.+--+-- The type @'Chain1' t@, for any @'Semigroupoidal' t@, is meant to be the+-- same as @'SF' t@ (the semigroupoidal functor combinator for @t@) and+-- represents "one or more" applications of @f@ to @t@.+--+-- The advantage of using 'Chain' and 'Chain1' over 'MF' or 'SF' is that+-- they provide a universal interface for pattern matching and constructing+-- such values, which may simplify working with new such functor+-- combinators you might encounter.+module Data.HFunctor.Chain (+ -- * 'Chain'+ Chain(..)+ , foldChain+ , unfoldChain+ , unrollMF+ , rerollMF+ , unrollingMF+ -- * 'Chain1'+ , Chain1(..)+ , foldChain1+ , unfoldChain1+ , unrollingSF+ , unrollSF+ , rerollSF+ , fromChain1+ -- ** Matchable+ -- | The following conversions between 'Chain' and 'Chain1' are only+ -- possible if @t@ is 'Matchable'+ , splittingChain1+ , splitChain1+ , matchingChain+ , unmatchChain+ ) where++import Control.Natural+import Control.Natural.IsoF+import Data.Functor.Classes+import Data.HBifunctor+import Data.HBifunctor.Associative+import Data.HBifunctor.Tensor+import Data.HFunctor+import Data.HFunctor.Interpret+import Data.Kind+import Data.Typeable+import GHC.Generics hiding (C)++-- | A useful construction that works like a "non-empty linked list" of @t+-- f@ applied to itself multiple times. That is, it contains @t f f@, @t+-- f (t f f)@, @t f (t f (t f f))@, etc, with @f@ occuring /one or more/+-- times. It is meant to be the same as @'SF' t@.+--+-- A @'Chain1' t f a@ is explicitly one of:+--+-- * @f a@+-- * @t f f a@+-- * @t f (t f f) a@+-- * @t f (t f (t f f)) a@+-- * .. etc+--+-- Note that this is exactly the description of @'SF' t@. And that's "the+-- point": for all instances of 'Semigroupoidal', @'Chain1' t@ is+-- isomorphic to @'SF' t@ (witnessed by 'unrollingSF'). That's big picture+-- of 'SF': it's supposed to be a type that consists of all possible+-- self-applications of @f@ to @t@.+--+-- 'Chain1' gives you a way to work with all @'SF' t@ in a uniform way.+-- Unlike for @'SF' t f@ in general, you can always explicitly /pattern+-- match/ on a 'Chain1' (with its two constructors) and do what you please+-- with it. You can also /construct/ 'Chain1' using normal constructors+-- and functions.+--+-- You can convert in between @'SF' t f@ and @'Chain1' t f@ with 'unrollSF'+-- and 'rerollSF'.+--+-- See 'Chain' for a version that has an "empty" value.+--+-- This construction is inspired by iteratees and machines.+data Chain1 t f a = Done1 (f a)+ | More1 (t f (Chain1 t f) a)+ deriving (Typeable, Generic)++deriving instance (Eq (f a), Eq (t f (Chain1 t f) a)) => Eq (Chain1 t f a)+deriving instance (Ord (f a), Ord (t f (Chain1 t f) a)) => Ord (Chain1 t f a)+deriving instance (Show (f a), Show (t f (Chain1 t f) a)) => Show (Chain1 t f a)+deriving instance (Read (f a), Read (t f (Chain1 t f) a)) => Read (Chain1 t f a)+deriving instance (Functor f, Functor (t f (Chain1 t f))) => Functor (Chain1 t f)+deriving instance (Foldable f, Foldable (t f (Chain1 t f))) => Foldable (Chain1 t f)+deriving instance (Traversable f, Traversable (t f (Chain1 t f))) => Traversable (Chain1 t f)++instance (Eq1 f, Eq1 (t f (Chain1 t f))) => Eq1 (Chain1 t f) where+ liftEq eq = \case+ Done1 x -> \case+ Done1 y -> liftEq eq x y+ More1 _ -> False+ More1 x -> \case+ Done1 _ -> False+ More1 y -> liftEq eq x y++instance (Ord1 f, Ord1 (t f (Chain1 t f))) => Ord1 (Chain1 t f) where+ liftCompare c = \case+ Done1 x -> \case+ Done1 y -> liftCompare c x y+ More1 _ -> LT+ More1 x -> \case+ Done1 _ -> GT+ More1 y -> liftCompare c x y++instance (Show1 (t f (Chain1 t f)), Show1 f) => Show1 (Chain1 t f) where+ liftShowsPrec sp sl d = \case+ Done1 x -> showsUnaryWith (liftShowsPrec sp sl) "Done1" d x+ More1 xs -> showsUnaryWith (liftShowsPrec sp sl) "More1" d xs++instance (Functor f, Read1 (t f (Chain1 t f)), Read1 f) => Read1 (Chain1 t f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Done1" Done1+ <> readsUnaryWith (liftReadsPrec rp rl) "More1" More1++-- | Recursively fold down a 'Chain1'. Provide a function on how to handle+-- the "single @f@ case" ('inject'), and how to handle the "combined @t+-- f g@ case", and this will fold the entire @'Chain1' t f@ into a single+-- @g@.+--+-- This is a catamorphism.+foldChain1+ :: forall t f g. HBifunctor t+ => f ~> g -- ^ handle 'Done1'+ -> t f g ~> g -- ^ handle 'More1'+ -> Chain1 t f ~> g+foldChain1 f g = go+ where+ go :: Chain1 t f ~> g+ go = \case+ Done1 x -> f x+ More1 xs -> g (hright go xs)++-- | Recursively build up a 'Chain1'. Provide a function that takes some+-- starting seed @g@ and returns either "done" (@f@) or "continue further"+-- (@t f g@), and it will create a @'Chain1' t f@ from a @g@.+--+-- This is an anamorphism.+unfoldChain1+ :: forall t f (g :: Type -> Type). HBifunctor t+ => (g ~> f :+: t f g)+ -> g ~> Chain1 t f+unfoldChain1 f = go+ where+ go :: g ~> Chain1 t f+ go = (Done1 !*! More1 . hright go) . f++instance HBifunctor t => HFunctor (Chain1 t) where+ hmap f = foldChain1 (Done1 . f) (More1 . hleft f)++instance HBifunctor t => Inject (Chain1 t) where+ inject = Done1++instance (HBifunctor t, Semigroupoidal t) => Interpret (Chain1 t) where+ type C (Chain1 t) = CS t+ retract = \case+ Done1 x -> x+ More1 xs -> binterpret id retract xs+ interpret :: forall f g. CS t g => f ~> g -> Chain1 t f ~> g+ interpret f = go+ where+ go :: Chain1 t f ~> g+ go = \case+ Done1 x -> f x+ More1 xs -> binterpret f go xs++-- | A type @'SF' t@ is supposed to represent the successive application of+-- @t@s to itself. The type @'Chain1' t f@ is an actual concrete ADT that contains+-- successive applications of @t@ to itself, and you can pattern match on+-- each layer.+--+-- 'unrollingSF' states that the two types are isormorphic. Use 'unrollSF'+-- and 'rerollSF' to convert between the two.+unrollingSF :: forall t f. (Semigroupoidal t, Functor f) => SF t f <~> Chain1 t f+unrollingSF = isoF unrollSF rerollSF++-- | A type @'SF' t@ is supposed to represent the successive application of+-- @t@s to itself. 'unrollSF' makes that successive application explicit,+-- buy converting it to a literal 'Chain1' of applications of @t@ to+-- itself.+--+-- @+-- 'unrollSF' = 'unfoldChain1' 'matchSF'+-- @+unrollSF :: (Semigroupoidal t, Functor f) => SF t f ~> Chain1 t f+unrollSF = unfoldChain1 matchSF++-- | A type @'SF' t@ is supposed to represent the successive application of+-- @t@s to itself. 'rerollSF' takes an explicit 'Chain1' of applications+-- of @t@ to itself and rolls it back up into an @'SF' t@.+--+-- @+-- 'rerollSF' = 'foldChain1' 'inject' 'consSF'+-- @+rerollSF :: Semigroupoidal t => Chain1 t f ~> SF t f+rerollSF = foldChain1 inject consSF++-- | A useful construction that works like a "linked list" of @t f@ applied+-- to itself multiple times. That is, it contains @t f f@, @t f (t f f)@,+-- @t f (t f (t f f))@, etc, with @f@ occuring /zero or more/ times. It is+-- meant to be the same as @'MF' t@.+--+-- If @t@ is 'Monoidal', then it means we can "collapse" this linked list+-- into some final type @'MF' t@ ('rerollMF'), and also extract it back+-- into a linked list ('unrollMF').+--+-- So, a value of type @'Chain' t ('I' t) f a@ is one of either:+--+-- * @'I' t a@+-- * @f a@+-- * @t f f a@+-- * @t f (t f f) a@+-- * @t f (t f (t f f)) a@+-- * .. etc.+--+-- Note that this is /exactly/ what an @'MF' t@ is supposed to be. Using+-- 'Chain' allows us to work with all @'MF' t@s in a uniform way, with+-- normal pattern matching and normal constructors.+--+-- This construction is inspired by+-- <http://oleg.fi/gists/posts/2018-02-21-single-free.html>+data Chain t i f a = Done (i a)+ | More (t f (Chain t i f) a)++deriving instance (Eq (i a), Eq (t f (Chain t i f) a)) => Eq (Chain t i f a)+deriving instance (Ord (i a), Ord (t f (Chain t i f) a)) => Ord (Chain t i f a)+deriving instance (Show (i a), Show (t f (Chain t i f) a)) => Show (Chain t i f a)+deriving instance (Read (i a), Read (t f (Chain t i f) a)) => Read (Chain t i f a)+deriving instance (Functor i, Functor (t f (Chain t i f))) => Functor (Chain t i f)+deriving instance (Foldable i, Foldable (t f (Chain t i f))) => Foldable (Chain t i f)+deriving instance (Traversable i, Traversable (t f (Chain t i f))) => Traversable (Chain t i f)++instance (Eq1 i, Eq1 (t f (Chain t i f))) => Eq1 (Chain t i f) where+ liftEq eq = \case+ Done x -> \case+ Done y -> liftEq eq x y+ More _ -> False+ More x -> \case+ Done _ -> False+ More y -> liftEq eq x y++instance (Ord1 i, Ord1 (t f (Chain t i f))) => Ord1 (Chain t i f) where+ liftCompare c = \case+ Done x -> \case+ Done y -> liftCompare c x y+ More _ -> LT+ More x -> \case+ Done _ -> GT+ More y -> liftCompare c x y++instance (Show1 (t f (Chain t i f)), Show1 i) => Show1 (Chain t i f) where+ liftShowsPrec sp sl d = \case+ Done x -> showsUnaryWith (liftShowsPrec sp sl) "Done" d x+ More xs -> showsUnaryWith (liftShowsPrec sp sl) "More" d xs++instance (Functor i, Read1 (t f (Chain t i f)), Read1 i) => Read1 (Chain t i f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Done" Done+ <> readsUnaryWith (liftReadsPrec rp rl) "More" More++-- | Recursively fold down a 'Chain'. Provide a function on how to handle+-- the "single @f@ case" ('nilMF'), and how to handle the "combined @t f g@+-- case", and this will fold the entire @'Chain' t i) f@ into a single @g@.+--+-- This is a catamorphism.+foldChain+ :: forall t i f g. HBifunctor t+ => (i ~> g) -- ^ Handle 'Done'+ -> (t f g ~> g) -- ^ Handle 'More'+ -> Chain t i f ~> g+foldChain f g = go+ where+ go :: Chain t i f ~> g+ go = \case+ Done x -> f x+ More xs -> g (hright go xs)++-- | Recursively build up a 'Chain'. Provide a function that takes some+-- starting seed @g@ and returns either "done" (@i@) or "continue further"+-- (@t f g@), and it will create a @'Chain' t i f@ from a @g@.+--+-- This is an anamorphism.+unfoldChain+ :: forall t f (g :: Type -> Type) i. HBifunctor t+ => (g ~> i :+: t f g)+ -> g ~> Chain t i f+unfoldChain f = go+ where+ go :: g a -> Chain t i f a+ go = (Done !*! More . hright go) . f++instance HBifunctor t => HFunctor (Chain t i) where+ hmap f = foldChain Done (More . hleft f)++instance (Tensor t, i ~ I t) => Inject (Chain t i) where+ inject = More . hright Done . intro1++-- | We can collapse and interpret an @'Chain' t i@ if we have @'Tensor' t@.+instance (Monoidal t, i ~ I t) => Interpret (Chain t i) where+ type C (Chain t i) = CM t+ interpret+ :: forall f g. CM t g+ => f ~> g+ -> Chain t i f ~> g+ interpret f = upgradeC @t (Proxy @g) go+ where+ go :: CS t g => Chain t i f ~> g+ go = \case+ Done x -> pureT @t x+ More xs -> binterpret f go xs++-- | A 'Chain1' is "one or more linked @f@s", and a 'Chain' is "zero or+-- more linked @f@s". So, we can convert from a 'Chain1' to a 'Chain' that+-- always has at least one @f@.+--+-- The result of this function always is made with 'More' at the top level.+fromChain1 :: Tensor t => Chain1 t f ~> Chain t (I t) f+fromChain1 = foldChain1 (More . hright Done . intro1) More++-- | A type @'MF' t@ is supposed to represent the successive application of+-- @t@s to itself. The type @'Chain' t ('I' t) f@ is an actual concrete+-- ADT that contains successive applications of @t@ to itself, and you can+-- pattern match on each layer.+--+-- 'unrollingMF' states that the two types are isormorphic. Use 'unrollMF'+-- and 'rerollMF' to convert between the two.+unrollingMF :: Monoidal t => MF t f <~> Chain t (I t) f+unrollingMF = isoF unrollMF rerollMF++-- | A type @'MF' t@ is supposed to represent the successive application of+-- @t@s to itself. 'unrollMF' makes that successive application explicit,+-- buy converting it to a literal 'Chain' of applications of @t@ to+-- itself.+--+-- @+-- 'unrollMF' = 'unfoldChain' 'unconsMF'+-- @+unrollMF :: Monoidal t => MF t f ~> Chain t (I t) f+unrollMF = unfoldChain unconsMF++-- | A type @'MF' t@ is supposed to represent the successive application of+-- @t@s to itself. 'rerollSF' takes an explicit 'Chain' of applications of+-- @t@ to itself and rolls it back up into an @'MF' t@.+--+-- @+-- 'rerollMF' = 'foldChain' 'nilMF' 'consMF'+-- @+--+-- Because @t@ cannot be inferred from the input or output, you should call+-- this with /-XTypeApplications/:+--+-- @+-- 'rerollMF' \@'Control.Monad.Freer.Church.Comp'+-- :: 'Chain' Comp 'Data.Functor.Identity.Identity' f a -> 'Control.Monad.Freer.Church.Free' f a+-- @+rerollMF :: forall t f. Monoidal t => Chain t (I t) f ~> MF t f+rerollMF = foldChain (nilMF @t) consMF++-- | A @'Chain1' t f@ is like a non-empty linked list of @f@s, and+-- a @'Chain' t ('I' t) f@ is a possibly-empty linked list of @f@s. This+-- witnesses the fact that the former is isomorphic to @f@ consed to the+-- latter.+splittingChain1+ :: forall t f. (Matchable t, Functor f)+ => Chain1 t f <~> t f (Chain t (I t) f)+splittingChain1 = fromF unrollingSF+ . splittingSF @t+ . overHBifunctor id unrollingMF++-- | The "forward" function representing 'splittingChain1'. Provided here+-- as a separate function because it does not require @'Functor' f@.+splitChain1+ :: forall t f. Matchable t+ => Chain1 t f ~> t f (Chain t (I t) f)+splitChain1 = hright (unrollMF @t) . splitSF @t . rerollSF++-- | A @'Chain' t ('I' t) f@ is a linked list of @f@s, and a @'Chain1' t f@ is+-- a non-empty linked list of @f@s. This witnesses the fact that+-- a @'Chain' t (I t) f@ is either empty (@'I' t@) or non-empty (@'Chain1'+-- t f@).+matchingChain+ :: forall t f. (Matchable t, Functor f)+ => Chain t (I t) f <~> I t :+: Chain1 t f+matchingChain = fromF unrollingMF+ . matchingMF @t+ . overHBifunctor id unrollingSF++-- | The "reverse" function representing 'matchingChain'. Provided here+-- as a separate function because it does not require @'Functor' f@.+unmatchChain+ :: forall t f. Matchable t+ => I t :+: Chain1 t f ~> Chain t (I t) f+unmatchChain = unrollMF . (nilMF @t !*! fromSF @t) . hright rerollSF
+ src/Data/HFunctor/Final.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.HFunctor.Final+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Provides 'Final', which can be considered the "free 'Interpret' over+-- a constraint": generate a handy 'Interpret' instance for any constraint+-- @c@.+module Data.HFunctor.Final (+ Final(..)+ , fromFinal, toFinal+ , FreeOf(..), finalizing+ , hoistFinalC+ , liftFinal0+ , liftFinal1+ , liftFinal2+ ) where++import Control.Applicative+import Control.Applicative.Free+import Control.Applicative.Lift+import Control.Applicative.ListF+import Control.Monad+import Control.Monad.Freer.Church hiding (toFree)+import Control.Monad.Reader+import Control.Monad.Trans.Identity+import Control.Natural+import Control.Natural.IsoF+import Data.Constraint.Trivial+import Data.Functor.Apply.Free+import Data.Functor.Bind+import Data.Functor.Coyoneda+import Data.Functor.Plus+import Data.HFunctor+import Data.HFunctor.Interpret+import Data.Pointed+import qualified Control.Alternative.Free as Alt+import qualified Control.Applicative.Free.Fast as FAF++-- | A simple way to inject/reject into any eventual typeclass.+--+-- In a way, this is the "ultimate" multi-purpose 'Interpret' instance.+-- You can use this to inject an @f@ into a free structure of any+-- typeclass. If you want @f@ to have a 'Monad' instance, for example,+-- just use+--+-- @+-- 'inject' :: f a -> 'Final' 'Monad' f a+-- @+--+-- When you want to eventually interpret out the data, use:+--+-- @+-- 'interpret' :: (f '~>' g) -> 'Final' c f a -> g a+-- @+--+-- Essentially, @'Final' c@ is the "free c". @'Final' 'Monad'@ is the free+-- 'Monad', etc.+--+-- 'Final' can theoretically replace 'Ap', 'Ap1', 'ListF', 'NonEmptyF',+-- 'MaybeF', 'Free', 'Data.Functor.Identity.Identity', 'Coyoneda', and+-- other instances of 'FreeOf', if you don't care about being able to+-- pattern match on explicit structure.+--+-- However, it cannot replace 'Interpret' instances that are not free+-- structures, like 'Control.Applicative.Step.Step',+-- 'Control.Applicative.Step.Steps',+-- 'Control.Applicative.Backwards.Backwards', etc.+--+-- Note that this doesn't have instances for /all/ the typeclasses you+-- could lift things into; you probably have to define your own if you want+-- to use @'Final' c@ as an /instance/ of @c@ (using 'liftFinal0',+-- 'liftFinal1', 'liftFinal2' for help).+newtype Final c f a = Final+ { runFinal :: forall g. c g => (forall x. f x -> g x) -> g a }++-- | Lift an action into a 'Final'.+liftFinal0+ :: (forall g. c g => g a)+ -> Final c f a+liftFinal0 x = Final $ \_ -> x++-- | Map the action in a 'Final'.+liftFinal1+ :: (forall g. c g => g a -> g b)+ -> Final c f a+ -> Final c f b+liftFinal1 f x = Final $ \r -> f (runFinal x r)++-- | Merge two 'Final' actions.+liftFinal2+ :: (forall g. c g => g a -> g b -> g d)+ -> Final c f a+ -> Final c f b+ -> Final c f d+liftFinal2 f x y = Final $ \r -> f (runFinal x r) (runFinal y r)++instance Functor (Final Functor f) where+ fmap f = liftFinal1 (fmap f)++instance Functor (Final Apply f) where+ fmap f = liftFinal1 (fmap f)+instance Apply (Final Apply f) where+ (<.>) = liftFinal2 (<.>)+ liftF2 f = liftFinal2 (liftF2 f)++instance Functor (Final Bind f) where+ fmap f = liftFinal1 (fmap f)+instance Apply (Final Bind f) where+ (<.>) = liftFinal2 (<.>)+ liftF2 f = liftFinal2 (liftF2 f)+instance Bind (Final Bind f) where+ x >>- f = Final $ \r -> runFinal x r >>- \y -> runFinal (f y) r++instance Functor (Final Applicative f) where+ fmap f = liftFinal1 (fmap f)+instance Apply (Final Applicative f) where+ (<.>) = liftFinal2 (<*>)+ liftF2 f = liftFinal2 (liftA2 f)+instance Applicative (Final Applicative f) where+ pure x = liftFinal0 (pure x)+ (<*>) = liftFinal2 (<*>)+ liftA2 f = liftFinal2 (liftA2 f)++instance Functor (Final Alternative f) where+ fmap f = liftFinal1 (fmap f)+instance Apply (Final Alternative f) where+ (<.>) = liftFinal2 (<*>)+ liftF2 f = liftFinal2 (liftA2 f)+instance Applicative (Final Alternative f) where+ pure x = liftFinal0 (pure x)+ (<*>) = liftFinal2 (<*>)+ liftA2 f = liftFinal2 (liftA2 f)+instance Alternative (Final Alternative f) where+ empty = liftFinal0 empty+ (<|>) = liftFinal2 (<|>)++instance Functor (Final Monad f) where+ fmap f = liftFinal1 (fmap f)+instance Apply (Final Monad f) where+ (<.>) = liftFinal2 (<*>)+ liftF2 f = liftFinal2 (liftA2 f)+instance Applicative (Final Monad f) where+ pure x = liftFinal0 (pure x)+ (<*>) = liftFinal2 (<*>)+ liftA2 f = liftFinal2 (liftA2 f)+instance Monad (Final Monad f) where+ return x = liftFinal0 (return x)+ x >>= f = Final $ \r -> do+ y <- runFinal x r+ runFinal (f y) r++instance Functor (Final MonadPlus f) where+ fmap f = liftFinal1 (fmap f)+instance Applicative (Final MonadPlus f) where+ pure x = liftFinal0 (pure x)+ (<*>) = liftFinal2 (<*>)+ liftA2 f = liftFinal2 (liftA2 f)+instance Monad (Final MonadPlus f) where+ return x = liftFinal0 (return x)+ x >>= f = Final $ \r -> do+ y <- runFinal x r+ runFinal (f y) r+instance Alternative (Final MonadPlus f) where+ empty = liftFinal0 empty+ (<|>) = liftFinal2 (<|>)+instance MonadPlus (Final MonadPlus f) where+ mzero = liftFinal0 mzero+ mplus = liftFinal2 mplus++instance Pointed (Final Pointed f) where+ point x = liftFinal0 (point x)++instance Functor (Final (MonadReader r) f) where+ fmap f = liftFinal1 (fmap f)+instance Applicative (Final (MonadReader r) f) where+ pure x = liftFinal0 (pure x)+ (<*>) = liftFinal2 (<*>)+ liftA2 f = liftFinal2 (liftA2 f)+instance Apply (Final (MonadReader r) f) where+ (<.>) = liftFinal2 (<*>)+ liftF2 f = liftFinal2 (liftA2 f)+instance Monad (Final (MonadReader r) f) where+ return x = liftFinal0 (return x)+ x >>= f = Final $ \r -> do+ y <- runFinal x r+ runFinal (f y) r+instance MonadReader r (Final (MonadReader r) f) where+ ask = liftFinal0 ask+ local f = liftFinal1 (local f)++instance Functor (Final Alt f) where+ fmap f = liftFinal1 (fmap f)+instance Alt (Final Alt f) where+ (<!>) = liftFinal2 (<!>)++instance Functor (Final Plus f) where+ fmap f = liftFinal1 (fmap f)+instance Alt (Final Plus f) where+ (<!>) = liftFinal2 (<!>)+instance Plus (Final Plus f) where+ zero = liftFinal0 zero++-- | Re-interpret the context under a 'Final'.+hoistFinalC+ :: (forall g x. (c g => g x) -> (d g => g x))+ -> Final c f a+ -> Final d f a+hoistFinalC f (Final x) = Final $ \r -> f (x (\y -> f (r y)))++instance HFunctor (Final c) where+ hmap f x = Final $ \r -> runFinal x (r . f)++instance Inject (Final c) where+ inject x = Final ($ x)++instance Interpret (Final c) where+ type C (Final c) = c++ retract x = runFinal x id+ interpret f x = runFinal x f++-- | "Finalize" an 'Interpret' instance.+--+-- @+-- toFinal :: 'Coyoneda' f '~>' 'Final' 'Functor' f+-- toFinal :: 'Ap' f '~>' 'Final' 'Applicative' f+-- toFinal :: 'Alt' f '~>' 'Final' 'Alternative' f+-- toFinal :: 'Free' f '~>' 'Final' 'Monad' f+-- toFinal :: 'Lift' f '~>' 'Final' 'Pointed' f+-- toFinal :: 'ListF' f '~>' 'Final' 'Plus' f+-- @+--+-- Note that the instance of @c@ for @'Final' c@ must be defined.+--+-- This operation can potentially /forget/ structure in @t@. For example,+-- we have:+--+-- @+-- 'toFinal' :: 'Control.Applicative.Step.Steps' f ~> 'Final' 'Alt' f+-- @+--+-- In this process, we lose the "positional" structure of+-- 'Control.Applicative.Step.Steps'.+--+-- In the case where 'toFinal' doesn't lose any information, this will form+-- an isomorphism with 'fromFinal', and @t@ is known as the "Free @c@".+-- For such a situation, @t@ will have a 'FreeOf' instance.+toFinal :: (Interpret t, C t (Final c f)) => t f ~> Final c f+toFinal = interpret inject++-- | "Concretize" a 'Final'.++-- @+-- fromFinal :: 'Final' 'Functor' f '~>' 'Coyoneda' f+-- fromFinal :: 'Final' 'Applicative' f '~>' 'Ap' f+-- fromFinal :: 'Final' 'Alternative' f '~>' 'Alt' f+-- fromFinal :: 'Final' 'Monad' f '~>' 'Free' f+-- fromFinal :: 'Final' 'Pointed' f '~>' 'Lift' f+-- fromFinal :: 'Final' 'Plus' f '~>' 'ListF' f+-- @+--+-- This can be useful because 'Final' doesn't have a concrete structure+-- that you can pattern match on and inspect, but @t@ might.+--+-- In the case that this forms an isomorphism with 'toFinal', the @t@ will+-- have an instance of 'FreeOf'.+fromFinal :: (Interpret t, c (t f)) => Final c f ~> t f+fromFinal = interpret inject++-- | A typeclass associating a free structure with the typeclass it is free+-- on.+--+-- This essentially lists instances of 'Interpret' where a "trip" through+-- 'Final' will leave it unchanged.+--+-- @+-- 'fromFree' . 'toFree' == id+-- 'toFree' . 'fromFree' == id+-- @+--+-- This can be useful because 'Final' doesn't have a concrete structure+-- that you can pattern match on and inspect, but @t@ might. This lets you+-- work on a concrete structure if you desire.+class Interpret t => FreeOf c t | t -> c where+ fromFree :: t f ~> Final c f+ toFree :: Functor f => Final c f ~> t f++ default fromFree :: C t (Final c f) => t f ~> Final c f+ fromFree = toFinal+ default toFree :: c (t f) => Final c f ~> t f+ toFree = fromFinal++-- | The isomorphism between a free structure and its encoding as 'Final'.+finalizing :: (FreeOf c t, Functor f) => t f <~> Final c f+finalizing = isoF fromFree toFree++instance FreeOf Functor Coyoneda+instance FreeOf Applicative Ap+instance FreeOf Apply Ap1+instance FreeOf Applicative FAF.Ap+instance FreeOf Alternative Alt.Alt+instance FreeOf Monad Free+instance FreeOf Bind Free1+instance FreeOf Pointed Lift+instance FreeOf Pointed MaybeApply+instance FreeOf Alt NonEmptyF+instance FreeOf Plus ListF+instance FreeOf Unconstrained IdentityT
+ src/Data/HFunctor/Internal.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++module Data.HFunctor.Internal (+ HFunctor(..)+ , HBifunctor(..)+ , WrappedHBifunctor(..)+ , sumSum, prodProd+ , generalize, absorb+ ) where++import Control.Applicative.Backwards+import Control.Applicative.Free+import Control.Applicative.Lift+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Comonad.Trans.Env+import Control.Monad.Freer.Church+import Control.Monad.Trans.Compose+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Natural+import Control.Natural.IsoF+import Data.Bifunctor+import Data.Bifunctor.Joker+import Data.Coerce+import Data.Functor.Bind+import Data.Functor.Coyoneda+import Data.Functor.Day (Day(..))+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.Functor.These+import Data.Functor.Yoneda+import Data.Kind+import Data.Proxy+import Data.Tagged+import Data.Vinyl.CoRec+import Data.Vinyl.Core (Rec)+import Data.Vinyl.Recursive+import GHC.Generics hiding (C)+import qualified Control.Alternative.Free as Alt+import qualified Control.Applicative.Free.Fast as FAF+import qualified Control.Applicative.Free.Final as FA+import qualified Control.Monad.Free.Church as MC+import qualified Data.Functor.Day as D++-- | An 'HFunctor' can be thought of a unary "functor transformer" ---+-- a basic functor combinator. It takes a functor as input and returns+-- a functor as output.+--+-- It "enhances" a functor with extra structure (sort of like how a monad+-- transformer enhances a 'Monad' with extra structure).+--+-- As a uniform inteface, we can "swap the underlying functor" (also+-- sometimes called "hoisting"). This is what 'hmap' does: it lets us swap+-- out the @f@ in a @t f@ for a @t g@.+--+-- For example, the free monad 'Free' takes a 'Functor' and returns a new+-- 'Functor'. In the process, it provides a monadic structure over @f@.+-- 'hmap' lets us turn a @'Free' f@ into a @'Free' g@: a monad built over+-- @f@ can be turned into a monad built over @g@.+--+-- For the ability to move in and out of the enhanced functor, see+-- 'Data.HFunctor.Inject' and 'Data.HFunctor.Interpret.Interpret'.+--+-- This class is similar to 'Control.Monad.Morph.MFunctor' from+-- "Control.Monad.Morph", but instances must work without a 'Monad' constraint.+class HFunctor t where+ -- | If we can turn an @f@ into a @g@, then we can turn a @t f@ into+ -- a @t g@.+ --+ -- It must be the case that+ --+ -- @+ -- 'hmap' 'id' == id+ -- @+ --+ -- Essentially, @t f@ adds some "extra structure" to @f@. 'hmap'+ -- must swap out the functor, /without affecting the added structure/.+ --+ -- For example, @'ListF' f a@ is essentially a list of @f a@s. If we+ -- 'hmap' to swap out the @f a@s for @g a@s, then we must ensure that+ -- the "added structure" (here, the number of items in the list, and+ -- the ordering of those items) remains the same. So, 'hmap' must+ -- preserve the number of items in the list, and must maintain the+ -- ordering.+ --+ -- The law @'hmap' 'id' == id@ is a way of formalizing this property.+ hmap :: f ~> g -> t f ~> t g++ {-# MINIMAL hmap #-}++-- | A 'HBifunctor' is like an 'HFunctor', but it enhances /two/ different+-- functors instead of just one.+--+-- Usually, it enhaces them "together" in some sort of combining way.+--+-- This typeclass provides a uniform instance for "swapping out" or+-- "hoisting" the enhanced functors. We can hoist the first one with+-- 'hleft', the second one with 'hright', or both at the same time with+-- 'hbimap'.+--+-- For example, the @f :*: g@ type gives us "both @f@ and @g@":+--+-- @+-- data (f ':*:' g) a = f a :*: g a+-- @+--+-- It combines both @f@ and @g@ into a unified structure --- here, it does+-- it by providing both @f@ and @g@.+--+-- The single law is:+--+-- @+-- 'hbimap' 'id' id == id+-- @+--+-- This ensures that 'hleft', 'hright', and 'hbimap' do not affect the+-- structure that @t@ adds on top of the underlying functors.+class HBifunctor t where+ -- | Swap out the first transformed functor.+ hleft :: f ~> j -> t f g ~> t j g+ hleft = (`hbimap` id)++ -- | Swap out the second transformed functor.+ hright :: g ~> k -> t f g ~> t f k+ hright = hbimap id++ -- | Swap out both transformed functors at the same time.+ hbimap :: f ~> j -> g ~> k -> t f g ~> t j k+ hbimap f g = hleft f . hright g++ {-# MINIMAL hleft, hright | hbimap #-}++-- | Useful newtype to allow us to derive an 'HFunctor' instance from any+-- instance of 'HBifunctor', using -XDerivingVia.+--+-- For example, because we have @instance 'HBifunctor' 'Day'@, we can+-- write:+--+-- @+-- deriving via ('WrappedHBifunctor' 'Day' f) instance 'HFunctor' ('Day' f)+-- @+--+-- to give us an automatic 'HFunctor' instance and save us some work.+newtype WrappedHBifunctor t (f :: k -> Type) (g :: k -> Type) a+ = WrapHBifunctor { unwrapHBifunctor :: t f g a }+ deriving Functor++-- | Isomorphism between different varieities of ':+:'.+sumSum :: (f :+: g) <~> Sum f g+sumSum = isoF to_ from_+ where+ to_ (L1 x) = InL x+ to_ (R1 y) = InR y+ from_ (InL x) = L1 x+ from_ (InR y) = R1 y++-- | Isomorphism between different varieities of ':*:'.+prodProd :: (f :*: g) <~> Product f g+prodProd = isoF to_ from_+ where+ to_ (x :*: y) = Pair x y+ from_ (Pair x y) = x :*: y++-- | Turn 'Identity' into any @'Applicative' f@. Can be useful as an+-- argument to 'hmap', 'hbimap', or 'Data.HFunctor.Interpret.interpret'.+--+-- It is a more general form of 'Control.Monad.Morph.generalize' from+-- /mmorph/.+generalize :: Applicative f => Identity ~> f+generalize (Identity x) = pure x++-- | Natural transformation from any functor @f@ into 'Proxy'. Can be+-- useful for "zeroing out" a functor with 'hmap' or 'hbimap' or+-- 'Data.HFunctor.Interpret.interpret'.+absorb :: f ~> Proxy+absorb _ = Proxy++instance HFunctor Coyoneda where+ hmap = hoistCoyoneda++instance HFunctor Ap where+ hmap = hoistAp++instance HFunctor ListF where+ hmap f (ListF xs) = ListF (map f xs)++instance HFunctor NonEmptyF where+ hmap f (NonEmptyF xs) = NonEmptyF (fmap f xs)++instance HFunctor MaybeF where+ hmap f (MaybeF xs) = MaybeF (fmap f xs)++instance HFunctor (MapF k) where+ hmap f (MapF xs) = MapF (fmap f xs)++instance HFunctor (NEMapF k) where+ hmap f (NEMapF xs) = NEMapF (fmap f xs)++instance HFunctor Alt.Alt where+ hmap = Alt.hoistAlt++instance HFunctor Step where+ hmap f (Step n x) = Step n (f x)++instance HFunctor Steps where+ hmap f (Steps xs) = Steps (f <$> xs)++instance HFunctor Flagged where+ hmap f (Flagged b x) = Flagged b (f x)++instance HFunctor Free where+ hmap = hoistFree++instance HFunctor Free1 where+ hmap = hoistFree1++-- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or+-- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires+-- @'Functor' f@.+instance HFunctor MC.F where+ hmap = MC.hoistF++-- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or+-- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires+-- @'Functor' f@.+instance HFunctor MaybeT where+ hmap f = mapMaybeT f++instance HFunctor Yoneda where+ hmap f x = Yoneda $ f . runYoneda x++instance HFunctor FA.Ap where+ hmap = FA.hoistAp++instance HFunctor FAF.Ap where+ hmap = FAF.hoistAp++instance HFunctor IdentityT where+ hmap = mapIdentityT++instance HFunctor Lift where+ hmap = mapLift++instance HFunctor MaybeApply where+ hmap f (MaybeApply x) = MaybeApply (first f x)++instance HFunctor Backwards where+ hmap f (Backwards x) = Backwards (f x)++instance HFunctor WrappedApplicative where+ hmap f (WrapApplicative x) = WrapApplicative (f x)++instance HFunctor (ReaderT r) where+ hmap = mapReaderT++instance HFunctor Tagged where+ hmap _ = coerce++instance HFunctor Reverse where+ hmap f (Reverse x) = Reverse (f x)++instance (HFunctor s, HFunctor t) => HFunctor (ComposeT s t) where+ hmap f (ComposeT x) = ComposeT $ hmap (hmap f) x++instance Functor f => HFunctor ((:.:) f) where+ hmap f (Comp1 x) = Comp1 (f <$> x)++instance HFunctor (M1 i c) where+ hmap f (M1 x) = M1 (f x)++instance HFunctor Void2 where+ hmap _ = coerce++instance HFunctor (EnvT e) where+ hmap f (EnvT e x) = EnvT e (f x)++instance HFunctor Rec where+ hmap = rmap++instance HFunctor CoRec where+ hmap f (CoRec x) = CoRec (f x)++instance HBifunctor (:*:) where+ hleft f (x :*: y) = f x :*: y+ hright g (x :*: y) = x :*: g y+ hbimap f g (x :*: y) = f x :*: g y++instance HBifunctor Product where+ hleft f (Pair x y) = Pair (f x) y+ hright g (Pair x y) = Pair x (g y)+ hbimap f g (Pair x y) = Pair (f x) (g y)++instance HBifunctor Day where+ hleft = D.trans1+ hright = D.trans2+ hbimap f g (Day x y z) = Day (f x) (g y) z++instance HBifunctor (:+:) where+ hleft f = \case+ L1 x -> L1 (f x)+ R1 y -> R1 y++ hright g = \case+ L1 x -> L1 x+ R1 y -> R1 (g y)++ hbimap f g = \case+ L1 x -> L1 (f x)+ R1 y -> R1 (g y)++instance HBifunctor Sum where+ hleft f = \case+ InL x -> InL (f x)+ InR y -> InR y++ hright g = \case+ InL x -> InL x+ InR y -> InR (g y)++ hbimap f g = \case+ InL x -> InL (f x)+ InR y -> InR (g y)++instance HBifunctor These1 where+ hbimap f g = \case+ This1 x -> This1 (f x)+ That1 y -> That1 (g y)+ These1 x y -> These1 (f x) (g y)++instance HBifunctor Joker where+ hleft f (Joker x) = Joker (f x)+ hright _ = coerce+ hbimap f _ (Joker x) = Joker (f x)++instance HBifunctor Void3 where+ hleft _ = coerce+ hright _ = coerce+ hbimap _ _ = coerce++instance HBifunctor Comp where+ hleft f (x :>>= h) = f x :>>= h+ hright g (x :>>= h) = x :>>= (g . h)+ hbimap f g (x :>>= h) = f x :>>= (g . h)++instance HBifunctor t => HFunctor (WrappedHBifunctor t f) where+ hmap f = WrapHBifunctor . hright f . unwrapHBifunctor++deriving via (WrappedHBifunctor Day f) instance HFunctor (Day f)+deriving via (WrappedHBifunctor (:*:) f) instance HFunctor ((:*:) f)+deriving via (WrappedHBifunctor (:+:) f) instance HFunctor ((:+:) f)+deriving via (WrappedHBifunctor Product f) instance HFunctor (Product f)+deriving via (WrappedHBifunctor Sum f) instance HFunctor (Sum f)+deriving via (WrappedHBifunctor Joker f) instance HFunctor (Joker f)+deriving via (WrappedHBifunctor These1 f) instance HFunctor (These1 f)+deriving via (WrappedHBifunctor Void3 f) instance HFunctor (Void3 f)+deriving via (WrappedHBifunctor Comp f) instance HFunctor (Comp f)
+ src/Data/HFunctor/Interpret.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- |+-- Module : Data.HFunctor.Interpret+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- This module provides tools for working with unary functor combinators+-- that represent interpretable schemas.+--+-- These are types @t@ that take a functor @f@ and return a new functor @t+-- f@, enhancing @f@ with new structure and abilities.+--+-- For these, we have:+--+-- @+-- 'inject' :: f a -> t f a+-- @+--+-- which lets you "lift" an @f a@ into its transformed version, and also:+--+-- @+-- 'interpret'+-- :: C t g+-- => (forall x. f a -> g a)+-- -> t f a+-- -> g a+-- @+--+-- that lets you "interpret" a @t f a@ into a context @g a@, essentially+-- "running" the computaiton that it encodes. The context is required to+-- have a typeclass constraints that reflects what is "required" to be able+-- to run a functor combinator.+--+-- Every single instance provides different tools. Check out the instance+-- list for a nice list of useful combinators, or also the README for+-- a high-level rundown.+--+-- See "Data.Functor.Tensor" for binary functor combinators that mix+-- together two or more different functors.+module Data.HFunctor.Interpret (+ Interpret(..), forI+ -- * Utilities+ , getI+ , collectI+ , AndC+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Applicative.ListF+import Control.Applicative.Step+import Control.Comonad.Trans.Env (EnvT(..))+import Control.Monad.Freer.Church+import Control.Monad.Reader+import Control.Monad.Trans.Compose+import Control.Monad.Trans.Identity+import Control.Natural+import Data.Coerce+import Data.Constraint.Trivial+import Data.Functor.Bind+import Data.Functor.Coyoneda+import Data.Functor.Plus+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.Functor.These+import Data.HFunctor+import Data.Kind+import Data.Maybe+import Data.Pointed+import Data.Proxy+import Data.Semigroup.Foldable+import GHC.Generics hiding (C)+import qualified Control.Alternative.Free as Alt+import qualified Control.Applicative.Free as Ap+import qualified Control.Applicative.Free.Fast as FAF+import qualified Control.Applicative.Free.Final as FA+import qualified Data.Map.NonEmpty as NEM++-- | An 'Interpret' lets us move in and out of the "enhanced" 'Functor'.+--+-- For example, @'Free' f@ is @f@ enhanced with monadic structure. We get:+--+-- @+-- 'inject' :: f a -> 'Free' f a+-- 'interpret' :: 'Monad' m => (forall x. f x -> m x) -> 'Free' f a -> m a+-- @+--+-- 'inject' will let us use our @f@ inside the enhanced @'Free' f@.+-- 'interpret' will let us "extract" the @f@ from a @'Free' f@ if+-- we can give an /interpreting function/ that interprets @f@ into some+-- target 'Monad'.+--+-- The type family 'C' tells us the typeclass constraint of the "target"+-- functor. For 'Free', it is 'Monad', but for other 'Interpret'+-- instances, we might have other constraints.+--+-- We enforce that:+--+-- @+-- 'interpret' id . 'inject' == id+-- -- or+-- 'retract' . 'inject' == id+-- @+--+-- That is, if we lift a value into our structure, then immediately+-- interpret it out as itself, it should lave the value unchanged.+class Inject t => Interpret t where+ -- | The constraint on the target context of 'interpret'. It's+ -- basically the constraint that allows you to "exit" or "run" an+ -- 'Interpret'.+ type C t :: (Type -> Type) -> Constraint++ -- | Remove the @f@ out of the enhanced @t f@ structure, provided that+ -- @f@ satisfies the necessary constraints. If it doesn't, it needs to+ -- be properly 'interpret'ed out.+ retract :: C t f => t f ~> f+ retract = interpret id++ -- | Given an "interpeting function" from @f@ to @g@, interpret the @f@+ -- out of the @t f@ into a final context @g@.+ interpret :: C t g => (f ~> g) -> t f ~> g+ interpret f = retract . hmap f++ {-# MINIMAL retract | interpret #-}++-- | A convenient flipped version of 'interpret'.+forI+ :: (Interpret t, C t g)+ => t f a+ -> (f ~> g)+ -> g a+forI x f = interpret f x++-- | Useful wrapper over 'interpret' to allow you to directly extract+-- a value @b@ out of the @t f a@, if you can convert @f x@ into @b@.+--+-- Note that depending on the constraints on the interpretation of @t@, you+-- may have extra constraints on @b@.+--+-- * If @'C' t@ is 'Unconstrained', there are no constraints on @b@+-- * If @'C' t@ is 'Apply', @b@ needs to be an instance of 'Semigroup'+-- * If @'C' t@ is 'Applicative', @b@ needs to be an instance of 'Monoid'+--+-- For some constraints (like 'Monad'), this will not be usable.+--+-- @+-- -- get the length of the @Map String@ in the 'Step'.+-- 'collectI' length+-- :: Step (Map String) Bool+-- -> Int+-- @+getI+ :: (Interpret t, C t (Const b))+ => (forall x. f x -> b)+ -> t f a+ -> b+getI f = getConst . interpret (Const . f)++-- | Useful wrapper over 'getI' to allow you to collect a @b@ from all+-- instances of @f@ inside a @t f a@.+--+-- This will work if @'C' t@ is 'Unconstrained', 'Apply', or 'Applicative'.+--+-- @+-- -- get the lengths of all @Map String@s in the 'Ap.Ap'.+-- 'collectI' length+-- :: Ap (Map String) Bool+-- -> [Int]+-- @+collectI+ :: (Interpret t, C t (Const [b]))+ => (forall x. f x -> b)+ -> t f a+ -> [b]+collectI f = getI ((:[]) . f)++-- | A free 'Functor'+instance Interpret Coyoneda where+ type C Coyoneda = Functor++ retract = lowerCoyoneda+ interpret f (Coyoneda g x) = g <$> f x++-- | A free 'Applicative'+instance Interpret Ap.Ap where+ type C Ap.Ap = Applicative++ retract = \case+ Ap.Pure x -> pure x+ Ap.Ap x xs -> x <**> retract xs+ interpret = Ap.runAp++-- | A free 'Plus'+instance Interpret ListF where+ type C ListF = Plus++ retract = foldr (<!>) zero . runListF+ interpret f = foldr ((<!>) . f) zero . runListF++-- | A free 'Alt'+instance Interpret NonEmptyF where+ type C NonEmptyF = Alt++ retract = asum1 . runNonEmptyF+ interpret f = asum1 . fmap f . runNonEmptyF++-- | Technically, 'C' is over-constrained: we only need @'zero' :: f a@,+-- but we don't really have that typeclass in any standard hierarchies. We+-- use 'Plus' here instead, but we never use '<!>'. This would only go+-- wrong in situations where your type supports 'zero' but not '<!>', like+-- instances of 'Control.Monad.Fail.MonadFail' without+-- 'Control.Monad.MonadPlus'.+instance Interpret MaybeF where+ type C MaybeF = Plus++ retract = fromMaybe zero . runMaybeF+ interpret f = maybe zero f . runMaybeF++instance Monoid k => Interpret (MapF k) where+ type C (MapF k) = Plus++ retract = foldr (<!>) zero . runMapF+ interpret f = foldr ((<!>) . f) zero . runMapF++instance Monoid k => Interpret (NEMapF k) where+ type C (NEMapF k) = Alt++ retract = asum1 . runNEMapF+ interpret f = asum1 . fmap f . runNEMapF++-- | Equivalent to instance for @'EnvT' ('Data.Semigroup.Sum'+-- 'Numeric.Natural.Natural')@.+instance Interpret Step where+ type C Step = Unconstrained++ retract = stepVal+ interpret f = f . stepVal++instance Interpret Steps where+ type C Steps = Alt++ retract = asum1 . getSteps+ interpret f = asum1 . NEM.map f . getSteps++-- | Equivalent to instance for @'EnvT' 'Data.Semigroup.Any'@ and @'HLift'+-- 'IdentityT'@.+instance Interpret Flagged where+ type C Flagged = Unconstrained++ retract = flaggedVal+ interpret f = f . flaggedVal++-- | Technically, 'C' is over-constrained: we only need @'zero' :: f a@,+-- but we don't really have that typeclass in any standard hierarchies. We+-- use 'Plus' here instead, but we never use '<!>'. This would only go+-- wrong in situations where your type supports 'zero' but not '<!>', like+-- instances of 'Control.Monad.Fail.MonadFail' without+-- 'Control.Monad.MonadPlus'.+instance Interpret (These1 f) where+ type C (These1 f) = Plus+ retract = \case+ This1 _ -> zero+ That1 y -> y+ These1 _ y -> y+ interpret f = \case+ This1 _ -> zero+ That1 y -> f y+ These1 _ y -> f y++-- | A free 'Alternative'+instance Interpret Alt.Alt where+ type C Alt.Alt = Alternative++ interpret = Alt.runAlt++instance Plus f => Interpret ((:*:) f) where+ type C ((:*:) f) = Unconstrained+ retract (_ :*: y) = y++instance Plus f => Interpret (Product f) where+ type C (Product f) = Unconstrained+ retract (Pair _ y) = y++-- | Technically, 'C' is over-constrained: we only need @'zero' :: f a@,+-- but we don't really have that typeclass in any standard hierarchies. We+-- use 'Plus' here instead, but we never use '<!>'. This would only go+-- wrong in situations where your type supports 'zero' but not '<!>', like+-- instances of 'Control.Monad.Fail.MonadFail' without+-- 'Control.Monad.MonadPlus'.+instance Interpret ((:+:) f) where+ type C ((:+:) f) = Plus+ retract = \case+ L1 _ -> zero+ R1 y -> y++-- | Technically, 'C' is over-constrained: we only need @'zero' :: f a@,+-- but we don't really have that typeclass in any standard hierarchies. We+-- use 'Plus' here instead, but we never use '<!>'. This would only go+-- wrong in situations where your type supports 'zero' but not '<!>', like+-- instances of 'Control.Monad.Fail.MonadFail' without+-- 'Control.Monad.MonadPlus'.+instance Interpret (Sum f) where+ type C (Sum f) = Plus+ retract = \case+ InL _ -> zero+ InR y -> y++instance Interpret (M1 i c) where+ type C (M1 i c) = Unconstrained+ retract (M1 x) = x+ interpret f (M1 x) = f x++-- | A free 'Monad'+instance Interpret Free where+ type C Free = Monad++ retract = retractFree+ interpret = interpretFree++-- | A free 'Bind'+instance Interpret Free1 where+ type C Free1 = Bind++ retract = retractFree1+ interpret = interpretFree1++-- | A free 'Applicative'+instance Interpret FA.Ap where+ type C FA.Ap = Applicative++ retract = FA.retractAp+ interpret = FA.runAp++-- | A free 'Applicative'+instance Interpret FAF.Ap where+ type C FAF.Ap = Applicative++ retract = FAF.retractAp+ interpret = FAF.runAp++-- | A free 'Unconstrained'+instance Interpret IdentityT where+ type C IdentityT = Unconstrained++ retract = coerce+ interpret f = f . runIdentityT++-- | A free 'Pointed'+instance Interpret Lift where+ type C Lift = Pointed++ retract = elimLift point id+ interpret = elimLift point++-- | A free 'Pointed'+instance Interpret MaybeApply where+ type C MaybeApply = Pointed++ retract = either id point . runMaybeApply+ interpret f = either f point . runMaybeApply++instance Interpret Backwards where+ type C Backwards = Unconstrained++ retract = forwards+ interpret f = f . forwards++instance Interpret WrappedApplicative where+ type C WrappedApplicative = Unconstrained++ retract = unwrapApplicative+ interpret f = f . unwrapApplicative++-- | A free 'MonadReader', but only when applied to a 'Monad'.+instance Interpret (ReaderT r) where+ type C (ReaderT r) = MonadReader r++ retract x = runReaderT x =<< ask+ interpret f x = f . runReaderT x =<< ask++-- | This ignores the environment, so @'interpret' /= 'hbind'@+instance Monoid e => Interpret (EnvT e) where+ type C (EnvT e) = Unconstrained++ retract (EnvT _ x) = x+ interpret f (EnvT _ x) = f x++instance Interpret Reverse where+ type C Reverse = Unconstrained++ retract = getReverse+ interpret f = f . getReverse++-- | The only way for this to obey @'retract' . 'inject' == 'id'@ is to+-- have it impossible to retract out of.+instance Interpret ProxyF where+ type C ProxyF = Impossible++ retract = absurdible . reProxy++reProxy :: p f a -> Proxy f+reProxy _ = Proxy++-- | The only way for this to obey @'retract' . 'inject' == 'id'@ is to+-- have it impossible to retract out of.+instance Monoid e => Interpret (ConstF e) where+ type C (ConstF e) = Impossible++ retract = absurdible . reProxy++-- | A constraint on @a@ for both @c a@ and @d a@. Requiring @'AndC'+-- 'Show' 'Eq' a@ is the same as requiring @('Show' a, 'Eq' a)@.+class (c a, d a) => AndC c d a+instance (c a, d a) => AndC c d a++instance (Interpret s, Interpret t) => Interpret (ComposeT s t) where+ type C (ComposeT s t) = AndC (C s) (C t)++ retract = interpret retract . getComposeT+ interpret f = interpret (interpret f) . getComposeT++-- | Never uses 'inject'+instance Interpret t => Interpret (HLift t) where+ type C (HLift t) = C t+ retract = \case+ HPure x -> x+ HOther x -> retract x+ interpret f = \case+ HPure x -> f x+ HOther x -> interpret f x++-- | Never uses 'inject'+instance Interpret t => Interpret (HFree t) where+ type C (HFree t) = C t+ retract = \case+ HReturn x -> x+ HJoin x -> interpret retract x
+ test/Spec.hs view
@@ -0,0 +1,10 @@+import Test.Tasty+import Tests.HBifunctor+import Tests.HFunctor++main :: IO ()+main = defaultMain $+ testGroup "Tests" [ hfunctorTests+ , hbifunctorTests+ ]+
+ test/Tests/HBifunctor.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Tests.HBifunctor (+ hbifunctorTests+ ) where++import Control.Applicative+import Control.Monad.Freer.Church+import Control.Natural.IsoF+import Data.Bifunctor+import Data.Bifunctor.Joker+import Data.Functor+import Data.Functor.Combinator+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Sum+import Data.HBifunctor.Associative+import Data.HBifunctor.Tensor+import Data.HFunctor.Chain+import Data.Maybe+import Data.Proxy+import Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog+import Tests.Util+import qualified Data.Semigroup as S+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++hbimapProp+ :: forall t f g m a.+ ( HBifunctor t+ , Monad m+ , Show (t f g a), Eq (t f g a)+ )+ => Gen (t f g a)+ -> PropertyT m ()+hbimapProp gx = do+ x <- forAll gx+ hbimap id id x === x++associatingProp+ :: forall t f g h m a.+ ( Associative t+ , Monad m+ , Functor f, Functor g, Functor h+ , Show (t f (t g h) a)+ , Show (t (t f g) h a)+ , Eq (t f (t g h) a)+ , Eq (t (t f g) h a)+ )+ => Gen (t f (t g h) a)+ -> Gen (t (t f g) h a)+ -> PropertyT m ()+associatingProp = isoProp (associating @t)++matchingSFProp+ :: forall t f m a.+ ( Semigroupoidal t+ , Monad m+ , Functor f+ , Show (f a), Eq (f a)+ , Show (SF t f a), Eq (SF t f a)+ , Show (t f (SF t f) a), Eq (t f (SF t f) a)+ )+ => Gen (SF t f a)+ -> Gen (f a)+ -> Gen (t f (SF t f) a)+ -> PropertyT m ()+matchingSFProp gx gy gz = isoProp (matchingSF @t) gx (sumGen gy gz)++unrollingSFProp+ :: forall t f m a.+ ( Semigroupoidal t+ , Monad m+ , Functor f+ , Show (SF t f a), Eq (SF t f a)+ , Show (f a), Eq (f a)+ , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)+ )+ => Gen (SF t f a)+ -> Gen (Chain1 t f a)+ -> PropertyT m ()+unrollingSFProp = isoProp (unrollingSF @t)++consSFProp+ :: forall t f m a.+ ( Semigroupoidal t+ , Monad m+ , Show (t f (SF t f) a)+ , Show (SF t f a), Eq (SF t f a)+ )+ => Gen (t f (SF t f) a)+ -> PropertyT m ()+consSFProp gx = do+ x <- forAll gx+ appendSF (hleft inject x) === consSF x++toSFProp+ :: forall t f m a.+ ( Semigroupoidal t+ , Monad m+ , Show (t f f a)+ , Show (SF t f a), Eq (SF t f a)+ )+ => Gen (t f f a)+ -> PropertyT m ()+toSFProp gx = do+ x <- forAll gx+ appendSF (hbimap inject inject x) === toSF x++biretractProp+ :: forall t f m a.+ ( Semigroupoidal t+ , CS t f+ , Monad m+ , Show (t f f a)+ , Show (f a), Eq (f a)+ )+ => Gen (t f f a)+ -> PropertyT m ()+biretractProp gx = do+ x <- forAll gx+ retract (appendSF (hbimap inject inject x)) === biretract x++binterpretProp+ :: forall t f m a.+ ( Semigroupoidal t+ , CS t f+ , Monad m+ , Show (t f f a)+ , Show (f a), Eq (f a)+ )+ => Gen (t f f a)+ -> PropertyT m ()+binterpretProp gx = do+ x <- forAll gx+ biretract x === binterpret id id x++rightIdentityProp+ :: forall t f m a.+ ( Tensor t+ , Monad m+ , Functor f+ , Show (f a), Eq (f a)+ , Show (t f (I t) a), Eq (t f (I t) a)+ )+ => Gen (f a)+ -> Gen (t f (I t) a)+ -> PropertyT m ()+rightIdentityProp = isoProp (rightIdentity @t)++leftIdentityProp+ :: forall t g m a.+ ( Tensor t+ , Monad m+ , Functor g+ , Show (g a), Eq (g a)+ , Show (t (I t) g a), Eq (t (I t) g a)+ )+ => Gen (g a)+ -> Gen (t (I t) g a)+ -> PropertyT m ()+leftIdentityProp = isoProp (leftIdentity @t)++splittingMFProp+ :: forall t f m a.+ ( Monoidal t+ , Monad m+ , Show (I t a), Eq (I t a)+ , Show (MF t f a), Eq (MF t f a)+ , Show (t f (MF t f) a), Eq (t f (MF t f) a)+ )+ => Gen (MF t f a)+ -> Gen ((I t :+: t f (MF t f)) a)+ -> PropertyT m ()+splittingMFProp = isoProp (splittingMF @t)++unrollingMFProp+ :: forall t f m a.+ ( Monoidal t+ , Monad m+ , Show (MF t f a), Eq (MF t f a)+ , Show (I t a), Eq (I t a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ )+ => Gen (MF t f a)+ -> Gen (Chain t (I t) f a)+ -> PropertyT m ()+unrollingMFProp = isoProp (unrollingMF @t)++toMFProp+ :: forall t f m a.+ ( Monoidal t+ , Monad m+ , Show (t f f a)+ , Show (MF t f a), Eq (MF t f a)+ )+ => Gen (t f f a)+ -> PropertyT m ()+toMFProp gx = do+ x <- forAll gx+ reviewF (splittingMF @t) (R1 (hright (inject @(MF t)) x)) === toMF @t x++fromSFProp+ :: forall t f m a.+ ( Monoidal t+ , Monad m+ , Show (SF t f a)+ , Show (MF t f a), Eq (MF t f a)+ )+ => Gen (SF t f a)+ -> PropertyT m ()+fromSFProp gx = do+ x <- forAll gx+ reviewF (splittingMF @t) (R1 (splitSF @t x)) === fromSF @t x++pureTProp+ :: forall t f m a.+ ( Monoidal t+ , Monad m+ , C (MF t) f+ , Show (I t a)+ , Show (f a), Eq (f a)+ )+ => Gen (I t a)+ -> PropertyT m ()+pureTProp gx = do+ x <- forAll gx+ retract (reviewF (splittingMF @t) (L1 x)) === pureT @t @f x++splittingSFProp+ :: forall t f m a.+ ( Matchable t+ , Monad m+ , Show (SF t f a), Eq (SF t f a)+ , Show (t f (MF t f) a), Eq (t f (MF t f) a)+ )+ => Gen (SF t f a)+ -> Gen (t f (MF t f) a)+ -> PropertyT m ()+splittingSFProp = isoProp (splittingSF @t)++matchingMFProp+ :: forall t f m a.+ ( Matchable t+ , Monad m+ , Show (I t a), Eq (I t a)+ , Show (MF t f a), Eq (MF t f a)+ , Show (SF t f a), Eq (SF t f a)+ )+ => Gen (MF t f a)+ -> Gen ((I t :+: SF t f) a)+ -> PropertyT m ()+matchingMFProp = isoProp (matchingMF @t)++matchingChainProp+ :: forall t f m a.+ ( Matchable t+ , Monad m+ , Functor f+ , Show (f a), Eq (f a)+ , Show (I t a), Eq (I t a)+ , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ )+ => Gen (Chain t (I t ) f a)+ -> Gen ((I t :+: Chain1 t f) a)+ -> PropertyT m ()+matchingChainProp = isoProp (matchingChain @t)++genChain+ :: forall t f m a. (MonadGen m, TestHBifunctor t)+ => m (f a)+ -> Maybe (m (I t a))+ -> m (Chain t (I t) f a)+genChain gx gy = go+ where+ go = case gy of+ Nothing -> More <$> genHB @t gx go+ Just gy' -> Gen.bool >>= \case+ False -> Done <$> gy'+ True -> More <$> genHB @t gx go++maybeSumGen+ :: Maybe (Gen (f a))+ -> Gen (g a)+ -> Gen ((f :+: g) a)+maybeSumGen = maybe (fmap R1) sumGen++hbifunctorProps+ :: forall t f a.+ ( TestHBifunctor t+ , Show (t f f a), Eq (t f f a)+ )+ => Gen (f a)+ -> TestTree+hbifunctorProps gx = testGroup "HBifunctor"+ . map (uncurry testProperty . second property) $+ [ ("hbimap", hbimapProp @t (genHB gx gx))+ ]++semigroupoidalProps+ :: forall t f a.+ ( Semigroupoidal t+ , TestHBifunctor t+ , TestHFunctor (SF t)+ , CS t f+ , Functor f+ , Show (t f (t f f) a) , Eq (t f (t f f) a)+ , Show (t (t f f) f a) , Eq (t (t f f) f a)+ , Show (t f f a)+ , Show (t f (SF t f) a) , Eq (t f (SF t f) a)+ , Show (SF t f a) , Eq (SF t f a)+ , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> TestTree+semigroupoidalProps gx = testGroup "Semigroupoidal"+ . map (uncurry testProperty . second property) $+ [ ("associating", associatingProp @t (genHB gx (genHB gx gx)) (genHB (genHB gx gx) gx))+ , ("matchingSF" , matchingSFProp @t (genHF gx) gx (genHB gx (genHF gx)))+ , ("unrollingSF", unrollingSFProp @t (genHF gx) (genHF gx))+ , ("consSF" , consSFProp @t (genHB gx (genHF gx)))+ , ("toSF" , toSFProp @t (genHB gx gx))+ , ("biretract" , biretractProp @t (genHB gx gx))+ , ("binterpret" , binterpretProp @t (genHB gx gx))+ ]++monoidalProps+ :: forall t f a.+ ( Monoidal t+ , TestHBifunctor t+ , TestHFunctor (MF t)+ , TestHFunctor (SF t)+ , CM t f+ , Functor f+ , Show (t f (I t) a) , Eq (t f (I t) a)+ , Show (t (I t) f a) , Eq (t (I t) f a)+ , Show (t f (MF t f) a) , Eq (t f (MF t f) a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ , Show (t f f a)+ , Show (MF t f a) , Eq (MF t f a)+ , Show (SF t f a)+ , Show (I t a) , Eq (I t a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> Maybe (Gen (I t a))+ -> TestTree+monoidalProps gx gy = testGroup "Monoidal"+ . map (uncurry testProperty . second property)+ . catMaybes $+ [ gy <&> \y -> ("rightIdentity", rightIdentityProp @t gx (genHB gx y))+ , gy <&> \y -> ("leftIdentity" , leftIdentityProp @t gx (genHB y gx))+ , Just ("splittingMF", splittingMFProp @t (genHF gx) (maybeSumGen gy (genHB gx (genHF gx))))+ , Just ("unrollingMF", unrollingMFProp @t (genHF gx) (genChain gx gy))+ , Just ("toMF" , toMFProp @t (genHB gx gx))+ , Just ("fromSF" , fromSFProp @t (genHF gx))+ , gy <&> \y -> ("pureT" , pureTProp @t @f y)+ ]++matchableProps+ :: forall t f a.+ ( Matchable t+ , TestHBifunctor t+ , TestHFunctor (MF t)+ , TestHFunctor (SF t)+ , Functor f+ , Show (t f (MF t f) a) , Eq (t f (MF t f) a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ , Show (t f (Chain1 t f) a) , Eq (t f (Chain1 t f) a)+ , Show (MF t f a) , Eq (MF t f a)+ , Show (SF t f a) , Eq (SF t f a)+ , Show (I t a) , Eq (I t a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> Maybe (Gen (I t a))+ -> TestTree+matchableProps gx gy = testGroup "Matchable"+ . map (uncurry testProperty . second property) $+ [ ("splittingSF" , splittingSFProp @t (genHF gx) (genHB gx (genHF gx)))+ , ("matchingMF" , matchingMFProp @t (genHF gx) (maybeSumGen gy (genHF gx)))+ , ("matchingChain", matchingChainProp @t (genChain gx gy) (maybeSumGen gy (genHF gx)))+ ]++semigroupoidalProps_+ :: forall t f a.+ ( Semigroupoidal t+ , TestHBifunctor t+ , TestHFunctor (SF t)+ , CS t f+ , Functor f+ , Show (t f (t f f) a) , Eq (t f (t f f) a)+ , Show (t (t f f) f a) , Eq (t (t f f) f a)+ , Show (t f f a) , Eq (t f f a)+ , Show (t f (SF t f) a) , Eq (t f (SF t f) a)+ , Show (SF t f a) , Eq (SF t f a)+ , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> [TestTree]+semigroupoidalProps_ gx = [ hbifunctorProps @t gx, semigroupoidalProps @t gx ]++monoidalProps_+ :: forall t f a.+ ( Monoidal t+ , TestHBifunctor t+ , TestHFunctor (MF t)+ , TestHFunctor (SF t)+ , CM t f+ , CS t f+ , Functor f+ , Show (t f (t f f) a) , Eq (t f (t f f) a)+ , Show (t (t f f) f a) , Eq (t (t f f) f a)+ , Show (t f (I t) a) , Eq (t f (I t) a)+ , Show (t (I t) f a) , Eq (t (I t) f a)+ , Show (t f (MF t f) a) , Eq (t f (MF t f) a)+ , Show (t f (SF t f) a) , Eq (t f (SF t f) a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ , Show (t f (Chain1 t f) a) , Eq (t f (Chain1 t f) a)+ , Show (t f f a) , Eq (t f f a)+ , Show (MF t f a) , Eq (MF t f a)+ , Show (SF t f a) , Eq (SF t f a)+ , Show (I t a) , Eq (I t a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> Maybe (Gen (I t a))+ -> [TestTree]+monoidalProps_ gx gy = semigroupoidalProps_ @t gx ++ [ monoidalProps @t gx gy ]++matchableProps_+ :: forall t f a.+ ( Matchable t+ , TestHBifunctor t+ , TestHFunctor (MF t)+ , TestHFunctor (SF t)+ , CM t f+ , CS t f+ , Functor f+ , Show (t f (t f f) a) , Eq (t f (t f f) a)+ , Show (t (t f f) f a) , Eq (t (t f f) f a)+ , Show (t f (I t) a) , Eq (t f (I t) a)+ , Show (t (I t) f a) , Eq (t (I t) f a)+ , Show (t f (MF t f) a) , Eq (t f (MF t f) a)+ , Show (t f (SF t f) a) , Eq (t f (SF t f) a)+ , Show (t f (Chain t (I t) f) a), Eq (t f (Chain t (I t) f) a)+ , Show (t f (Chain1 t f) a) , Eq (t f (Chain1 t f) a)+ , Show (t f f a) , Eq (t f f a)+ , Show (MF t f a) , Eq (MF t f a)+ , Show (SF t f a) , Eq (SF t f a)+ , Show (I t a) , Eq (I t a)+ , Show (f a) , Eq (f a)+ )+ => Gen (f a)+ -> Maybe (Gen (I t a))+ -> [TestTree]+matchableProps_ gx gy = monoidalProps_ @t gx gy ++ [ matchableProps @t gx gy ]++hbifunctorTests :: TestTree+hbifunctorTests = testGroup "HBifunctors"+ [ testGroup "Sum" $ matchableProps_ @(:+:) listGen Nothing+ , testGroup "Sum'" $ matchableProps_ @Sum listGen Nothing+ , testGroup "Product" $ matchableProps_ @(:*:) listGen (Just (pure Proxy))+ , testGroup "Product'" $ matchableProps_ @Product listGen (Just (pure Proxy))+ , testGroup "These1" $ monoidalProps_ @These1 listGen Nothing+ , testGroup "LeftF" $ semigroupoidalProps_ @LeftF listGen+ , testGroup "Joker" $ semigroupoidalProps_ @Joker listGen+ , testGroup "RightF" $ semigroupoidalProps_ @RightF listGen+ , testGroup "Day" $ matchableProps_ @Day (Const . S.Sum <$> intGen)+ (Just (Identity <$> intGen))+ , testGroup "Comp" $ monoidalProps_ @Comp (Gen.list (Range.linear 0 3) intGen)+ (Just (Identity <$> intGen))+ ]
+ test/Tests/HFunctor.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Tests.HFunctor (+ hfunctorTests+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Data.Bifunctor+import Data.Functor.Bind+import Data.Functor.Combinator+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.HFunctor+import GHC.Generics (M1(..), Meta(..))+import Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog+import Tests.Util+import qualified Control.Applicative.Free.Fast as FAF+import qualified Control.Applicative.Free.Final as FA+import qualified Data.Semigroup as S+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++hmapProp+ :: forall t f m a.+ ( HFunctor t+ , Monad m+ , Show (t f a), Eq (t f a)+ )+ => Gen (t f a)+ -> PropertyT m ()+hmapProp gx = do+ x <- forAll gx+ hmap id x === x++retractingProp+ :: forall t f m a.+ ( Interpret t+ , Monad m+ , C t f+ , Show (f a)+ , Show (t f a)+ , Eq (f a)+ )+ => Gen (f a)+ -> PropertyT m ()+retractingProp gx = do+ x <- forAll gx+ tripping x (inject @t) (Just . retract)++interpretProp+ :: forall t f m a.+ ( Interpret t+ , Monad m+ , C t f+ , Show (f a)+ , Show (t f a)+ , Eq (f a)+ )+ => Gen (t f a)+ -> PropertyT m ()+interpretProp gx = do+ x <- forAll gx+ retract x === interpret id x++hbindInjectProp+ :: forall t f m a.+ ( HBind t+ , Monad m+ , Show (t f a), Eq (t f a)+ )+ => Gen (t f a)+ -> PropertyT m ()+hbindInjectProp gx = do+ x <- forAll gx+ hbind inject x === x++hbindhjoinProp+ :: forall t f m a.+ ( HBind t+ , Monad m+ , Show (t (t f) a)+ , Show (t f a), Eq (t f a)+ )+ => Gen (t (t f) a)+ -> PropertyT m ()+hbindhjoinProp gx = do+ x <- forAll gx+ hbind id x === hjoin x++hjoinAssocProp+ :: forall t f m a.+ ( HBind t+ , Monad m+ , Show (t (t (t f)) a)+ , Show (t f a), Eq (t f a)+ )+ => Gen (t (t (t f)) a)+ -> PropertyT m ()+hjoinAssocProp gx = do+ x <- forAll gx+ hjoin (hjoin x) === hjoin (hmap hjoin x)++hfunctorProps+ :: forall t f a.+ ( TestHFunctor t+ , Show (t f a), Eq (t f a)+ )+ => Gen (f a)+ -> TestTree+hfunctorProps gx = testGroup "HFunctor"+ . map (uncurry testProperty . second property) $+ [ ("hmap", hmapProp @t (genHF gx))+ ]++hbindProps+ :: forall t f a.+ ( HBind t+ , TestHFunctor t+ , Show (t f a) , Eq (t f a)+ , Show (t (t f) a)+ , Show (t (t (t f)) a)+ )+ => Gen (f a)+ -> TestTree+hbindProps gx = testGroup "HBind"+ . map (uncurry testProperty . second property) $+ [ ("hbindInject", hbindInjectProp @t (genHF gx))+ , ("hbindhjoin" , hbindhjoinProp @t (genHF (genHF gx)))+ , ("hjoinAssoc" , hjoinAssocProp @t (genHF (genHF (genHF gx))))+ ]++interpretProps+ :: forall t f a.+ ( Interpret t+ , TestHFunctor t+ , C t f+ , Show (f a) , Eq (f a)+ , Show (t f a)+ )+ => Gen (f a)+ -> TestTree+interpretProps gx = testGroup "Interpret"+ . map (uncurry testProperty . second property) $+ [ ("retracting", retractingProp @t gx)+ , ("interpret" , interpretProp @t (genHF gx))+ ]++hbindProps_+ :: forall t f a.+ ( HBind t+ , TestHFunctor t+ , Show (t f a) , Eq (t f a)+ , Show (t (t f) a)+ , Show (t (t (t f)) a)+ )+ => Gen (f a)+ -> [TestTree]+hbindProps_ gx = [ hfunctorProps @t gx+ , hbindProps @t gx+ ]++interpretProps_+ :: forall t f a.+ ( Interpret t+ , TestHFunctor t+ , C t f+ , Show (f a) , Eq (f a)+ , Show (t f a) , Eq (t f a)+ )+ => Gen (f a)+ -> [TestTree]+interpretProps_ gx = [ hfunctorProps @t gx+ , interpretProps @t gx+ ]+++bindInterpProps_+ :: forall t f a.+ ( HBind t+ , Interpret t+ , TestHFunctor t+ , C t f+ , Show (f a) , Eq (f a)+ , Show (t f a) , Eq (t f a)+ , Show (t (t f) a)+ , Show (t (t (t f)) a)+ )+ => Gen (f a)+ -> [TestTree]+bindInterpProps_ gx = [ hfunctorProps @t gx+ , hbindProps @t gx+ , interpretProps @t gx+ ]++hfunctorTests :: TestTree+hfunctorTests = testGroup "HFunctors"+ [ testGroup "Ap" $ bindInterpProps_ @Ap (Const . S.Sum <$> intGen)+ , testGroup "Ap'" $ bindInterpProps_ @FA.Ap (Const . S.Sum <$> intGen)+ , testGroup "Ap''" $ bindInterpProps_ @FAF.Ap (Const . S.Sum <$> intGen)+ -- , testGroup "Alt" $ bindInterpProps_ @Alt (Const . S.Sum <$> intGen) -- TODO+ , testGroup "Coyoneda" $ bindInterpProps_ @Coyoneda listGen+ , testGroup "WrappedApplicative" $ bindInterpProps_ @WrappedApplicative listGen+ , testGroup "MaybeApply" $ bindInterpProps_ @MaybeApply listGen+ , testGroup "Lift" $ bindInterpProps_ @Lift listGen+ , testGroup "ListF" $ bindInterpProps_ @ListF (Gen.list (Range.linear 0 3) intGen)+ , testGroup "NonEmptyF" $ bindInterpProps_ @NonEmptyF (Gen.list (Range.linear 0 3) intGen)+ , testGroup "MaybeF" $ bindInterpProps_ @MaybeF listGen+ , testGroup "MapF" $ interpretProps_ @(MapF Ordering) (Gen.list (Range.linear 0 3) intGen)+ , testGroup "NEMapF" $ interpretProps_ @(NEMapF Ordering) (Gen.list (Range.linear 0 3) intGen)+ , testGroup "Free1" $ bindInterpProps_ @Free1 (Gen.list (Range.linear 0 3) intGen)+ , testGroup "Free" $ bindInterpProps_ @Free (Gen.list (Range.linear 0 3) intGen)+ , testGroup "Ap1" $ bindInterpProps_ @Ap1 (Const . S.Sum <$> intGen)+ , testGroup "EnvT" $ bindInterpProps_ @(EnvT Ordering) listGen+ , testGroup "IdentityT" $ bindInterpProps_ @IdentityT listGen+ -- , testGroup "ReaderT" [ hfunctorProps @(ReaderT Int) listGen ] -- no Show+ , testGroup "These1" $ bindInterpProps_ @(These1 []) listGen+ , testGroup "Reverse" $ bindInterpProps_ @Reverse listGen+ , testGroup "Backwards" $ bindInterpProps_ @Backwards listGen+ , testGroup "Comp" [ hfunctorProps @(Comp []) (Gen.list (Range.linear 0 3) intGen) ]+ , testGroup "Comp'" [ hfunctorProps @((:*:) []) (Gen.list (Range.linear 0 3) intGen) ]+ , testGroup "Step" $ bindInterpProps_ @Step listGen+ , testGroup "Steps" $ interpretProps_ @Steps listGen+ , testGroup "Flagged" $ bindInterpProps_ @Flagged listGen+ , testGroup "M1" $ bindInterpProps_ @(M1 () ('MetaData "" "" "" 'True)) listGen+ , testGroup "Product" $ bindInterpProps_ @((:*:) []) listGen+ , testGroup "Product'" $ bindInterpProps_ @(Product []) listGen+ , testGroup "Sum" $ bindInterpProps_ @((:+:) []) listGen+ , testGroup "Sum'" $ bindInterpProps_ @(Sum []) listGen+ , testGroup "ProxyF" $ hbindProps_ @ProxyF listGen+ , testGroup "RightF" $ hbindProps_ @(RightF []) listGen+ ]
+ test/Tests/Util.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Tests.Util (+ isoProp+ , sumGen+ , intGen+ , listGen+ , TestHFunctor(..)+ , TestHBifunctor(..)+ ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Applicative.Lift+import Control.Monad.Freer.Church+import Control.Natural.IsoF+import Data.Bifunctor.Joker+import Data.Function+import Data.Functor+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Combinator+import Data.Functor.Identity+import Data.Functor.Plus+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.GADT.Show+import Data.HBifunctor.Tensor+import Data.HFunctor.Chain+import Data.Semigroup (Any(..))+import Data.Semigroup.Traversable+import GHC.Generics (M1(..))+import Hedgehog hiding (HTraversable(..))+import qualified Control.Applicative.Free as Ap+import qualified Control.Applicative.Free.Fast as FAF+import qualified Control.Applicative.Free.Final as FA+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.NonEmpty as NEM+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++isoProp+ :: (Show (f a), Show (g a), Eq (f a), Eq (g a), Monad m)+ => (f <~> g)+ -> Gen (f a)+ -> Gen (g a)+ -> PropertyT m ()+isoProp i gx gy = do+ x <- forAll gx+ tripping x (viewF i) (Just . reviewF i)+ y <- forAll gy+ tripping y (reviewF i) (Just . viewF i)++sumGen :: MonadGen m => m (f a) -> m (g a) -> m ((f :+: g) a)+sumGen gx gy = Gen.bool >>= \case+ False -> L1 <$> gx+ True -> R1 <$> gy++intGen :: MonadGen m => m Int+intGen = Gen.integral (Range.linear 0 100)++listGen :: MonadGen m => m [Int]+listGen = Gen.list (Range.linear 0 100) intGen++instance (GShow f, GShow g) => Eq (Day f g a) where+ (==) = (==) `on` show++instance Show c => GShow (Const c) where+ gshowsPrec = showsPrec++instance (GShow f, GShow g) => GShow (Day f g) where+ gshowsPrec d (Day x y _) =+ showsBinaryWith gshowsPrec gshowsPrec "Day" d x y++instance (GShow f, GShow (t f (Chain1 t f))) => GShow (Chain1 t f) where+ gshowsPrec d = \case+ Done1 x -> gshowsPrec d x+ More1 xs -> gshowsPrec d xs++instance GShow Identity where+ gshowsPrec _ _ = showString "<Identity>"++instance (GShow i, GShow (t f (Chain t i f))) => GShow (Chain t i f) where+ gshowsPrec d = \case+ Done x -> gshowsPrec d x+ More xs -> gshowsPrec d xs++instance (GShow f, GShow g) => Show (Day f g a) where+ showsPrec = gshowsPrec++instance GShow f => GShow (Ap1 f) where+ gshowsPrec d (Ap1 x y) = case matchMF @Day y of+ L1 _ -> showsUnaryWith gshowsPrec "inject" d x+ R1 ys -> showsBinaryWith gshowsPrec gshowsPrec "Ap1" d x ys++instance GShow f => Eq (Ap1 f a) where+ (==) = (==) `on` show++instance GShow f => Show (Ap1 f a) where+ showsPrec = gshowsPrec++instance GShow f => GShow (Ap f) where+ gshowsPrec d = \case+ Ap.Pure _ -> showString "<pure>"+ Ap.Ap x xs -> showsBinaryWith gshowsPrec gshowsPrec "Ap" d x xs++instance GShow f => GShow (FA.Ap f) where+ gshowsPrec d = gshowsPrec @(Ap f) d . FA.runAp Ap.liftAp++instance GShow f => GShow (FAF.Ap f) where+ gshowsPrec d = gshowsPrec @(Ap f) d . FAF.runAp Ap.liftAp++instance GShow f => Show (Ap f a) where+ showsPrec = gshowsPrec++instance GShow f => Show (FA.Ap f a) where+ showsPrec = gshowsPrec++instance GShow f => Show (FAF.Ap f a) where+ showsPrec = gshowsPrec++instance GShow f => Eq (Ap f a) where+ (==) = (==) `on` show++instance GShow f => Eq (FA.Ap f a) where+ (==) = (==) `on` show++instance GShow f => Eq (FAF.Ap f a) where+ (==) = (==) `on` show++deriving instance (Show e, Show (f a)) => Show (EnvT e f a)+deriving instance (Eq e, Eq (f a)) => Eq (EnvT e f a)++instance (Show e, Show1 f) => Show1 (EnvT e f) where+ liftShowsPrec sp sl d (EnvT e x) =+ showsBinaryWith showsPrec (liftShowsPrec sp sl) "EnvT" d e x++instance (Eq e, Eq1 f) => Eq1 (EnvT e f) where+ liftEq eq (EnvT e x) (EnvT d y) = e == d && liftEq eq x y++instance Show1 (s (t f)) => Show1 (ComposeT s t f) where+ liftShowsPrec sp sl d (ComposeT x) =+ showsUnaryWith (liftShowsPrec sp sl) "ComposeT" d x++instance Eq1 (s (t f)) => Eq1 (ComposeT s t f) where+ liftEq eq (ComposeT x) (ComposeT y) = liftEq eq x y++instance Enum Any where+ toEnum = Any . toEnum+ fromEnum = fromEnum . getAny++instance Show1 V1 where+ liftShowsPrec _ _ _ = \case {}++instance Eq1 V1 where+ liftEq _ = \case {}++class HFunctor t => TestHFunctor t where+ genHF+ :: MonadGen m+ => m (f a)+ -> m (t f a)++ default genHF :: (Inject t, MonadGen m) => m (f a) -> m (t f a)+ genHF = fmap inject++class HFunctor t => HTraversable t where+ htraverse :: Applicative h => (forall x. f x -> h (g x)) -> t f a -> h (t g a)++instance TestHFunctor Step where+ genHF gx = Step <$> Gen.integral (Range.linear 0 25) <*> gx++instance TestHFunctor ListF where+ genHF gx = ListF <$> Gen.list (Range.linear 0 25) gx++instance TestHFunctor NonEmptyF where+ genHF gx = NonEmptyF <$> Gen.nonEmpty (Range.linear 1 25) gx++instance (Enum k, Bounded k, Ord k) => TestHFunctor (MapF k) where+ genHF gx = MapF <$> Gen.map (Range.linear 0 10) kv+ where+ kv = (,) <$> Gen.enumBounded+ <*> gx++instance (Enum k, Bounded k, Ord k) => TestHFunctor (NEMapF k) where+ genHF gx = do+ mp <- Gen.map (Range.linear 0 10) kv+ (k, v) <- kv+ pure . NEMapF $ NEM.insertMap k v mp+ where+ kv = (,) <$> Gen.enumBounded+ <*> gx++instance TestHFunctor Steps where+ genHF gx = do+ mp <- Gen.map (Range.linear 0 10) kv+ (k, v) <- kv+ pure . Steps $ NEM.insertMap k v mp+ where+ kv = (,) <$> Gen.integral (Range.linear 0 25)+ <*> gx++instance TestHFunctor Ap where+ genHF gx = fmap NE.last+ . sequence1+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 0 3) gx++instance TestHFunctor FA.Ap where+ genHF gx = fmap NE.last+ . sequence1+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 0 3) gx++instance TestHFunctor FAF.Ap where+ genHF gx = fmap NE.last+ . sequence1+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 0 3) gx++instance TestHFunctor Ap1 where+ genHF gx = fmap NE.last+ . sequence1+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 1 3) gx++instance TestHFunctor Free where+ genHF gx = fmap NE.last+ . sequence+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 0 3) gx++instance TestHFunctor Free1 where+ genHF gx = fmap NE.last+ . sequence1+ . fmap inject+ <$> Gen.nonEmpty (Range.linear 1 3) gx++instance TestHFunctor t => TestHFunctor (HLift t) where+ genHF gx = Gen.bool >>= \case+ False -> HPure <$> gx+ True -> HOther <$> genHF gx++instance (Enum e, Bounded e) => TestHFunctor (EnvT e) where+ genHF gx = EnvT <$> Gen.enumBounded <*> gx++instance (TestHFunctor s, HTraversable s, TestHFunctor t) => TestHFunctor (ComposeT s t) where+ genHF gx = fmap ComposeT+ . htraverse (genHF @t . pure)+ =<< genHF @s gx++instance TestHFunctor Flagged where+ genHF gx = Flagged <$> Gen.bool <*> gx++instance HTraversable Flagged where+ htraverse f (Flagged b x) = Flagged b <$> f x++class HBifunctor t => TestHBifunctor t where+ genHB+ :: MonadGen m+ => m (f a)+ -> m (g a)+ -> m (t f g a)++instance TestHBifunctor (:+:) where+ genHB = sumGen++instance TestHBifunctor Sum where+ genHB gx gy = sumGen gx gy <&> \case+ L1 x -> InL x+ R1 y -> InR y++instance TestHBifunctor (:*:) where+ genHB gx gy = (:*:) <$> gx <*> gy++instance TestHBifunctor Product where+ genHB gx gy = Pair <$> gx <*> gy++instance TestHBifunctor Day where+ genHB gx gy = do+ f <- Gen.bool <&> \case+ False -> const+ True -> flip const+ Day <$> gx <*> gy <*> pure f++instance TestHBifunctor These1 where+ genHB gx gy = Gen.enumBounded >>= \case+ LT -> This1 <$> gx+ EQ -> That1 <$> gy+ GT -> These1 <$> gx <*> gy++instance TestHBifunctor Comp where+ genHB gx gy = (:>>=) <$> gx <*> fmap const gy++instance TestHBifunctor LeftF where+ genHB gx _ = LeftF <$> gx++instance TestHBifunctor Joker where+ genHB gx _ = Joker <$> gx++instance TestHBifunctor RightF where+ genHB _ gy = RightF <$> gy++instance TestHBifunctor t => TestHFunctor (Chain1 t) where+ genHF x = go+ where+ go = Gen.bool >>= \case+ False -> Done1 <$> x+ True -> More1 <$> genHB x go++deriving instance Eq (f a) => Eq (WrappedApplicative f a)+deriving instance Show (f a) => Show (WrappedApplicative f a)++-- | We cannot test the pure case, huhu+instance TestHFunctor MaybeApply++deriving instance (Eq a, Eq (f a)) => Eq (MaybeApply f a)+deriving instance (Show a, Show (f a)) => Show (MaybeApply f a)++-- | We cannot test the pure case, huhu+instance TestHFunctor Lift++-- | We cannot test the pure case, huhu+instance TestHFunctor (These1 f)++instance TestHFunctor MaybeF where+ genHF gx = Gen.bool >>= \case+ False -> pure $ MaybeF Nothing+ True -> MaybeF . Just <$> gx++instance TestHFunctor IdentityT where+instance TestHFunctor Coyoneda+instance TestHFunctor WrappedApplicative+instance TestHFunctor Reverse+instance TestHFunctor Backwards+instance Applicative f => TestHFunctor (Comp f)+instance TestHFunctor (M1 i c)+instance Plus f => TestHFunctor ((:*:) f)+instance Plus f => TestHFunctor (Product f)+instance TestHFunctor ((:+:) f)+instance TestHFunctor (Sum f)+instance TestHFunctor ProxyF+instance TestHFunctor (RightF f)