diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +Changelog +========= + +Version 0.1.0.0 +--------------- + +*June 19, 2019* + + + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/functor-combinators.cabal b/functor-combinators.cabal new file mode 100644 --- /dev/null +++ b/functor-combinators.cabal @@ -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 + 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 diff --git a/src/Control/Applicative/ListF.hs b/src/Control/Applicative/ListF.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/ListF.hs @@ -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 + diff --git a/src/Control/Applicative/Step.hs b/src/Control/Applicative/Step.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Step.hs @@ -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 {} diff --git a/src/Control/Monad/Freer/Church.hs b/src/Control/Monad/Freer/Church.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Church.hs @@ -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 #-} + diff --git a/src/Control/Natural/IsoF.hs b/src/Control/Natural/IsoF.hs new file mode 100644 --- /dev/null +++ b/src/Control/Natural/IsoF.hs @@ -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) diff --git a/src/Data/Functor/Apply/Free.hs b/src/Data/Functor/Apply/Free.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Apply/Free.hs @@ -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 + diff --git a/src/Data/Functor/Combinator.hs b/src/Data/Functor/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Combinator.hs @@ -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 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 diff --git a/src/Data/Functor/Combinator/Unsafe.hs b/src/Data/Functor/Combinator/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Combinator/Unsafe.hs @@ -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 + diff --git a/src/Data/HBifunctor.hs b/src/Data/HBifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Data/HBifunctor.hs @@ -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 diff --git a/src/Data/HBifunctor/Associative.hs b/src/Data/HBifunctor/Associative.hs new file mode 100644 --- /dev/null +++ b/src/Data/HBifunctor/Associative.hs @@ -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 diff --git a/src/Data/HBifunctor/Tensor.hs b/src/Data/HBifunctor/Tensor.hs new file mode 100644 --- /dev/null +++ b/src/Data/HBifunctor/Tensor.hs @@ -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 diff --git a/src/Data/HFunctor.hs b/src/Data/HFunctor.hs new file mode 100644 --- /dev/null +++ b/src/Data/HFunctor.hs @@ -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 diff --git a/src/Data/HFunctor/Chain.hs b/src/Data/HFunctor/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Data/HFunctor/Chain.hs @@ -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 +-- +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 diff --git a/src/Data/HFunctor/Final.hs b/src/Data/HFunctor/Final.hs new file mode 100644 --- /dev/null +++ b/src/Data/HFunctor/Final.hs @@ -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 diff --git a/src/Data/HFunctor/Internal.hs b/src/Data/HFunctor/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HFunctor/Internal.hs @@ -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) diff --git a/src/Data/HFunctor/Interpret.hs b/src/Data/HFunctor/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Data/HFunctor/Interpret.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,10 @@ +import Test.Tasty +import Tests.HBifunctor +import Tests.HFunctor + +main :: IO () +main = defaultMain $ + testGroup "Tests" [ hfunctorTests + , hbifunctorTests + ] + diff --git a/test/Tests/HBifunctor.hs b/test/Tests/HBifunctor.hs new file mode 100644 --- /dev/null +++ b/test/Tests/HBifunctor.hs @@ -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)) + ] diff --git a/test/Tests/HFunctor.hs b/test/Tests/HFunctor.hs new file mode 100644 --- /dev/null +++ b/test/Tests/HFunctor.hs @@ -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 + ] diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Util.hs @@ -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 "" + +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 "" + 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)