├── .gitignore ├── CHANGELOG.md ├── Setup.lhs ├── .hlint.yaml ├── cabal.haskell-ci ├── .reuse └── dep5 ├── README.md ├── src └── Data │ ├── HKD │ ├── Index.hs │ ├── Profunctor │ │ └── Unsafe.hs │ ├── Profunctor.hs │ ├── Index │ │ └── Internal.hs │ ├── Orphans.hs │ ├── Contravariant.hs │ └── Classes.hs │ ├── Function │ └── Coerce.hs │ ├── Traversable │ └── Confusing.hs │ └── HKD.hs ├── cabal.project ├── LICENSES ├── BSD-2-Clause.txt └── Apache-2.0.txt ├── hkd.cabal └── LICENSE.md /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.2 2 | --- 3 | * Rewrite 4 | 5 | 0.1 6 | --- 7 | * Initial hackage release 8 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | import Distribution.Simple (defaultMain) 3 | main :: IO () 4 | main = defaultMain 5 | \end{code} 6 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | 2 | - ignore: { name: Use const } 3 | - ignore: { name: Avoid lambda } 4 | - ignore: { name: Avoid lambda using `infix` } 5 | - ignore: { name: Redundant lambda } 6 | - ignore: { name: Eta reduce } 7 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | allow-failures: <8.6 4 | irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | docspec: True 7 | -------------------------------------------------------------------------------- /.reuse/dep5: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: hkd 3 | Upstream-Contact: Edward Kmett 4 | Source: http://github.com/ekmett/hkd 5 | 6 | Files: * 7 | Copyright: 2021-2023 Edward Kmett 8 | License: BSD-2-Clause OR Apache-2.0 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hkd 2 | === 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/hkd.svg)](https://hackage.haskell.org/package/hkd) 5 | 6 | This package provides some types and utilities for working with the "higher-kinded data" pattern in Haskell. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /src/Data/HKD/Index.hs: -------------------------------------------------------------------------------- 1 | {-# Language Unsafe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2021 Edward Kmett, 5 | -- License : BSD-2-style OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : non-portable 9 | 10 | module Data.HKD.Index 11 | ( Index(Index,IZ,IS,KnownIZ,KnownIS) 12 | , lowerFin, liftFin 13 | , pattern IntIndex 14 | , toIndex 15 | , Length 16 | , KnownLength 17 | , len 18 | ) where 19 | 20 | import Data.HKD.Index.Internal 21 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | allow-newer: 4 | constraints-extras:base, 5 | constraints-extras:template-haskell, 6 | constraints-extras:constraints 7 | 8 | source-repository-package 9 | type: git 10 | branch: main 11 | location: git@github.com:ekmett/bifunctors.git 12 | 13 | source-repository-package 14 | type: git 15 | branch: main 16 | location: git@github.com:ekmett/comonad.git 17 | 18 | source-repository-package 19 | type: git 20 | branch: main 21 | location: git@github.com:ekmett/constraints.git 22 | 23 | source-repository-package 24 | type: git 25 | branch: main 26 | location: git@github.com:ekmett/contravariant.git 27 | 28 | source-repository-package 29 | type: git 30 | branch: main 31 | location: git@github.com:ekmett/profunctors.git 32 | 33 | source-repository-package 34 | type: git 35 | branch: main 36 | location: git@github.com:ekmett/numeric-fin.git 37 | -------------------------------------------------------------------------------- /src/Data/HKD/Profunctor/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | module Data.HKD.Profunctor.Unsafe 3 | ( FProfunctor(..) 4 | ) where 5 | 6 | import Data.Coerce 7 | import Data.Kind 8 | import Data.HKD.Classes 9 | 10 | class (forall c. FFunctor (p c)) => FProfunctor (p :: (i -> Type) -> (j -> Type) -> Type) where 11 | fdimap :: (a ~> b) -> (c ~> d) -> p b c -> p a d 12 | fdimap = \f g -> flmap f . frmap g 13 | {-# inline fdimap #-} 14 | 15 | flmap :: (a ~> b) -> p b c -> p a c 16 | flmap = \f -> fdimap f id 17 | {-# inline flmap #-} 18 | 19 | frmap :: (a ~> b) -> p c a -> p c b 20 | frmap = fdimap id 21 | {-# inline frmap #-} 22 | 23 | (##.) :: forall a b c. (forall x. Coercible (c x) (b x)) => (b ~> c) -> p a b -> p a c 24 | (##.) = \_ p -> p `seq` frmap go p where 25 | go :: forall y. Coercible (c y) (b y) => b y -> c y 26 | go = coerce 27 | {-# inline (##.) #-} 28 | 29 | (.##) :: forall a b c. (forall x. Coercible (b x) (a x)) => p b c -> (a ~> b) -> p a c 30 | (.##) = \p _ -> p `seq` flmap go p where 31 | go :: forall y. Coercible (b y) (a y) => a y -> b y 32 | go = coerce 33 | {-# inline (.##) #-} 34 | 35 | -------------------------------------------------------------------------------- /LICENSES/BSD-2-Clause.txt: -------------------------------------------------------------------------------- 1 | Copyright 2021-2023 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/Data/Function/Coerce.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | {-# options_haddock hide #-} 3 | 4 | module Data.Function.Coerce 5 | ( (#.) 6 | , (.#) 7 | , pattern Coerce 8 | , Coe(..) 9 | , runCoe 10 | ) where 11 | 12 | import Control.Applicative 13 | import Control.Arrow 14 | import Control.Monad.Fix 15 | import Control.Monad.Zip 16 | import Control.Monad.Reader 17 | import Control.Category 18 | import Data.Coerce 19 | import Prelude hiding (id,(.)) 20 | 21 | (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c 22 | (#.) _ = coerce 23 | {-# inline (#.) #-} 24 | 25 | (.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c 26 | (.#) f _ = coerce f 27 | {-# inline (.#) #-} 28 | 29 | infixr 9 #., .# 30 | 31 | pattern Coerce :: Coercible a b => a -> b 32 | pattern Coerce x <- (coerce -> x) where 33 | Coerce x = coerce x 34 | 35 | type role Coe representational representational 36 | data Coe a b where 37 | Fun :: (a -> b) -> Coe a b 38 | Coe :: Coercible a b => Coe a b 39 | 40 | runCoe :: Coe a b -> a -> b 41 | runCoe (Fun f) = f 42 | runCoe Coe = coerce 43 | 44 | instance Functor (Coe a) where 45 | fmap f = \case 46 | Coe -> Fun (f . coerce) 47 | Fun g -> Fun (f . g) 48 | {-# inline fmap #-} 49 | 50 | instance Applicative (Coe a) where 51 | pure a = Fun \_ -> a 52 | (<*>) = \f g -> Fun (runCoe f <*> runCoe g) 53 | (*>) = \_ x -> x 54 | (<*) = const 55 | {-# inline pure #-} 56 | {-# inline (<*>) #-} 57 | {-# inline (*>) #-} 58 | {-# inline (<*) #-} 59 | 60 | instance Monad (Coe a) where 61 | (>>=) = \m f -> Fun \a -> runCoe (f (runCoe m a)) a 62 | {-# inline (>>=) #-} 63 | 64 | instance MonadFix (Coe a) where 65 | mfix = \f -> Fun $ mfix (runCoe . f) 66 | {-# inline mfix #-} 67 | 68 | instance MonadZip (Coe a) where 69 | mzipWith = liftA2 70 | {-# inline mzipWith #-} 71 | 72 | instance Category Coe where 73 | id = Coe 74 | {-# inline id #-} 75 | 76 | Fun f . Fun g = Fun (f . g) 77 | Coe . x = coerce x 78 | x . Coe = coerce x 79 | {-# inline (.) #-} 80 | 81 | instance Arrow Coe where 82 | arr = Fun 83 | {-# inline arr #-} 84 | 85 | first = \case 86 | Coe -> Coe 87 | Fun f -> Fun (first f) 88 | {-# inline first #-} 89 | 90 | second = \case 91 | Coe -> Coe 92 | Fun f -> Fun (second f) 93 | {-# inline second #-} 94 | 95 | Coe *** Coe = Coe 96 | f *** g = Fun (runCoe f *** runCoe g) 97 | {-# inline (***) #-} 98 | 99 | f &&& g = Fun (runCoe f &&& runCoe g) 100 | {-# inline (&&&) #-} 101 | 102 | instance ArrowLoop Coe where 103 | loop = \case 104 | Coe -> Coe 105 | Fun f -> Fun (loop f) 106 | {-# inline loop #-} 107 | 108 | instance ArrowApply Coe where 109 | app = Fun (uncurry runCoe) 110 | {-# inline app #-} 111 | 112 | instance ArrowChoice Coe where 113 | left = \case 114 | Coe -> Coe 115 | Fun f -> Fun (left f) 116 | {-# inline left #-} 117 | 118 | right = \case 119 | Coe -> Coe 120 | Fun f -> Fun (right f) 121 | {-# inline right #-} 122 | 123 | Coe +++ Coe = Coe 124 | f +++ g = Fun (runCoe f +++ runCoe g) 125 | {-# inline (+++) #-} 126 | 127 | (|||) = \f g -> Fun (runCoe f ||| runCoe g) 128 | {-# inline (|||) #-} 129 | 130 | instance Semigroup m => Semigroup (Coe a m) where 131 | (<>) = \f g -> Fun (runCoe f <> runCoe g) 132 | {-# inline (<>) #-} 133 | 134 | instance Monoid m => Monoid (Coe a m) where 135 | mempty = Fun mempty 136 | {-# inline mempty #-} 137 | 138 | instance MonadReader a (Coe a) where 139 | reader = Fun 140 | {-# inline reader #-} 141 | ask = Coe 142 | {-# inline ask #-} 143 | local f g = g . Fun f 144 | {-# inline local #-} 145 | -------------------------------------------------------------------------------- /hkd.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: hkd 3 | version: 0.2 4 | synopsis: "higher-kinded data" 5 | description: 6 | "Higher-kinded data" utilities, e.g. 7 | . 8 | @ 9 | class FFunctor t where 10 | \ ffmap :: (f ~> g) -> t f -> t g 11 | @ 12 | . 13 | and other classes and types. 14 | . 15 | /Note:/ this package is experimental. 16 | . 17 | /See also:/ @distributive@. 18 | 19 | homepage: https://github.com/ekmett/distributive/tree/main/hkd#readme 20 | license: BSD-2-Clause OR Apache-2.0 21 | license-file: LICENSE.md 22 | author: Edward Kmett 23 | maintainer: Edward Kmett 24 | copyright: (c) 2019-2021 Edward Kmett 25 | (c) 2019-2021, Oleg Grenrus 26 | (c) 2021 Aaron Vargo 27 | category: Data Structures 28 | build-type: Simple 29 | extra-source-files: 30 | .hlint.yaml 31 | extra-doc-files: 32 | README.md 33 | CHANGELOG.md 34 | 35 | tested-with: 36 | GHC == 8.6.5, 37 | GHC == 8.8.4, 38 | GHC == 8.10.3, 39 | GHC == 9.0.1, 40 | GHC == 9.4.4 41 | 42 | source-repository head 43 | type: git 44 | location: git://github.com/ekmett/distributive.git 45 | subdir: hkd 46 | 47 | common base 48 | default-language: Haskell2010 49 | ghc-options: -Wall 50 | default-extensions: 51 | AllowAmbiguousTypes 52 | BangPatterns 53 | BlockArguments 54 | ConstraintKinds 55 | DataKinds 56 | DefaultSignatures 57 | DeriveAnyClass 58 | DeriveDataTypeable 59 | DeriveGeneric 60 | DeriveTraversable 61 | DerivingVia 62 | EmptyCase 63 | ExistentialQuantification 64 | ExplicitNamespaces 65 | FlexibleContexts 66 | FlexibleInstances 67 | FunctionalDependencies 68 | GADTs 69 | InstanceSigs 70 | LambdaCase 71 | LiberalTypeSynonyms 72 | MagicHash 73 | NoStarIsType 74 | PartialTypeSignatures 75 | PatternSynonyms 76 | PolyKinds 77 | QuantifiedConstraints 78 | RankNTypes 79 | RoleAnnotations 80 | ScopedTypeVariables 81 | StandaloneDeriving 82 | TupleSections 83 | TypeApplications 84 | TypeFamilies 85 | TypeOperators 86 | UndecidableInstances 87 | UndecidableSuperClasses 88 | ViewPatterns 89 | 90 | other-extensions: 91 | CPP 92 | GeneralizedNewtypeDeriving 93 | Safe 94 | Trustworthy 95 | Unsafe 96 | UnboxedTuples 97 | 98 | library 99 | import: base 100 | 101 | hs-source-dirs: src 102 | 103 | other-modules: 104 | Data.HKD.Orphans 105 | Data.Traversable.Confusing 106 | 107 | exposed-modules: 108 | Data.HKD 109 | Data.HKD.Classes 110 | Data.HKD.Contravariant 111 | Data.HKD.Profunctor 112 | Data.HKD.Profunctor.Unsafe 113 | Data.HKD.Index 114 | Data.HKD.Index.Internal 115 | Data.Function.Coerce 116 | 117 | -- TODO: remove Data.Function.Coerce and use Data.Profunctor.Unsafe 118 | -- Data.HKD.Profunctor 119 | 120 | ghc-options: -Wall -fexpose-all-unfoldings -fspecialize-aggressively 121 | ghc-options: -O2 122 | 123 | if impl(ghc >=8.0) 124 | ghc-options: -Wno-trustworthy-safe 125 | 126 | if impl(ghc >=8.4) 127 | ghc-options: 128 | -Wincomplete-uni-patterns -Wincomplete-record-updates 129 | -Wredundant-constraints -Widentities -Wmissing-export-lists 130 | 131 | if impl(ghc >= 9.0) 132 | -- these flags may abort compilation with GHC-8.10 133 | -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 134 | ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode 135 | 136 | if impl(ghc >= 9.2) 137 | ghc-options: -finline-generics-aggressively 138 | 139 | build-depends: 140 | , base >=4.10 && <4.18 141 | , base-orphans >= 0.5.2 && < 1 142 | , contravariant ^>= 1.6 143 | , dependent-hashmap ^>= 0.1 144 | , dependent-sum ^>= 0.7.1 145 | , ghc-prim 146 | , hashable >= 1.3 && < 1.5 147 | , indexed-traversable ^>= 0.1 148 | , mtl ^>= 2.2 149 | , numeric-fin ^>= 0 150 | , some ^>= 1 151 | , tagged >= 0.7 && < 1 152 | , transformers ^>= 0.5 153 | -------------------------------------------------------------------------------- /src/Data/HKD/Profunctor.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | 3 | module Data.HKD.Profunctor 4 | ( FProfunctor(fdimap, flmap, frmap) 5 | , FStrong(..) 6 | , FChoice(..) 7 | , FCostrong(..) 8 | , FCochoice(..) 9 | , FStar(..) 10 | , FCostar(..) 11 | ) where 12 | 13 | import Data.Coerce 14 | -- import Data.Functor.Compose 15 | import Data.HKD.Classes 16 | import Data.HKD.Profunctor.Unsafe 17 | import GHC.Generics 18 | 19 | fswap :: (a :*: b) ~> (b :*: a) 20 | fswap (a :*: b) = b :*: a 21 | {-# inline fswap #-} 22 | 23 | class FProfunctor p => FStrong p where 24 | ffirst :: p a b -> p (a :*: c) (b :*: c) 25 | ffirst = fdimap fswap fswap . fsecond 26 | fsecond :: p a b -> p (c :*: a) (c :*: b) 27 | fsecond = fdimap fswap fswap . ffirst 28 | {-# minimal ffirst | fsecond #-} 29 | {-# inline ffirst #-} 30 | {-# inline fsecond #-} 31 | 32 | fswaps :: (a :+: b) ~> (b :+: a) 33 | fswaps (L1 a) = R1 a 34 | fswaps (R1 b) = L1 b 35 | {-# inline fswaps #-} 36 | 37 | {- 38 | flensVL 39 | :: forall p s t a b. FStrong p 40 | => (forall f. Functor f => (forall x. a x -> f (b x)) -> forall y. s y -> f (t y)) 41 | -> p a b -> p s t 42 | flensVL l = fdimap hither yon . ffirst where 43 | hither :: s x -> (a :*: c) x 44 | hither = undefined 45 | yon :: (b :*: c) x -> t x 46 | yon = undefined 47 | 48 | -- (\s -> getCompose $ l (\a -> Compose (a :*: NT id)) s) (\(x :*: y) -> _ y x) . ffirst 49 | 50 | -- uncurry (flip id)) . ffirst 51 | {-# inline flensVL #-} 52 | -} 53 | 54 | class FProfunctor p => FChoice p where 55 | fleft :: p a b -> p (a :+: c) (b :+: c) 56 | fleft = fdimap fswaps fswaps . fright 57 | fright :: p a b -> p (c :+: a) (c :+: b) 58 | fright = fdimap fswaps fswaps . fleft 59 | {-# minimal fleft | fright #-} 60 | {-# inline fleft #-} 61 | {-# inline fright #-} 62 | 63 | class FProfunctor p => FCostrong p where 64 | funfirst :: p (a :*: c) (b :*: c) -> p a b 65 | funfirst = funsecond . fdimap fswap fswap 66 | funsecond :: p (c :*: a) (c :*: b) -> p a b 67 | funsecond = funfirst . fdimap fswap fswap 68 | {-# minimal funfirst | funsecond #-} 69 | {-# inline funfirst #-} 70 | {-# inline funsecond #-} 71 | 72 | class FProfunctor p => FCochoice p where 73 | funleft :: p (a :+: c) (b :+: c) -> p a b 74 | funleft = funright . fdimap fswaps fswaps 75 | funright :: p (c :+: a) (c :+: b) -> p a b 76 | funright = funleft . fdimap fswaps fswaps 77 | {-# minimal funleft | funright #-} 78 | {-# inline funleft #-} 79 | {-# inline funright #-} 80 | 81 | type role FStar representational representational nominal 82 | newtype FStar f a b = FStar { runFStar :: forall x. a x -> f (b x) } 83 | 84 | instance Functor f => FProfunctor (FStar f) where 85 | fdimap = \f g h -> FStar (fmap g . runFStar h . f) 86 | {-# inline fdimap #-} 87 | (.##) (p :: FStar f b c) (_ :: a ~> b) = FStar go where 88 | go :: forall y. Coercible (b y) (a y) => a y -> f (c y) 89 | go = coerce (runFStar p :: b y -> f (c y)) 90 | {-# inline (.##) #-} 91 | 92 | instance Functor f => FFunctor (FStar f a) where 93 | ffmap = \f h -> FStar (fmap f . runFStar h) 94 | {-# inline ffmap #-} 95 | 96 | -- type FCostar :: (Type -> Type) -> (i -> Type) -> (i -> Type) -> Type 97 | type role FCostar representational nominal representational 98 | newtype FCostar f a b = FCostar { runFCostar :: forall x. f (a x) -> b x } 99 | 100 | instance Functor f => FProfunctor (FCostar f) where 101 | fdimap = \f g h -> FCostar (g . runFCostar h . fmap f) 102 | {-# inline fdimap #-} 103 | (##.) (_ :: b ~> c) (p :: FCostar f a b) = FCostar go where 104 | go :: forall y. Coercible (c y) (b y) => f (a y) -> c y 105 | go = coerce (runFCostar p :: f (a y) -> b y) 106 | {-# inline (##.) #-} 107 | 108 | instance FFunctor (FCostar f a) where 109 | ffmap = \f h -> FCostar (f . runFCostar h) 110 | {-# inline ffmap #-} 111 | 112 | instance Functor f => FCostrong (FCostar f) where 113 | funfirst (f :: FCostar f (a :*: c) (b :*: c)) = FCostar f' where 114 | f' :: forall x. f (a x) -> b x 115 | f' fa = b where 116 | b :*: d = runFCostar f ((\a -> a :*: d) <$> fa) 117 | funsecond (f :: FCostar f (c :*: a) (c :*: b)) = FCostar f' where 118 | f' :: forall x. f (a x) -> b x 119 | f' fa = b where 120 | d :*: b = runFCostar f ((:*:) d <$> fa) 121 | {-# inline funfirst #-} 122 | {-# inline funsecond #-} 123 | -------------------------------------------------------------------------------- /src/Data/HKD/Index/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# Language GeneralizedNewtypeDeriving #-} 2 | {-# Language ImportQualifiedPost #-} 3 | {-# Language Unsafe #-} 4 | {-# options_haddock not-home #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2021 Edward Kmett, 8 | -- License : BSD-2-style OR Apache-2.0 9 | -- Maintainer : Edward Kmett 10 | -- Stability : provisional 11 | -- Portability : non-portable 12 | 13 | module Data.HKD.Index.Internal 14 | ( Index(UnsafeIndex,Index,IZ,IS,KnownIZ,KnownIS) 15 | , lowerFin, liftFin 16 | , pattern IntIndex 17 | , toIndex 18 | , Length 19 | , KnownLength 20 | , len 21 | ) where 22 | 23 | import Control.Arrow (first) 24 | import Data.Coerce 25 | import Data.GADT.Compare 26 | import Data.GADT.Show 27 | import Data.Proxy 28 | import Data.Kind 29 | import Data.Some 30 | import Data.Type.Coercion 31 | import Data.Type.Equality 32 | import GHC.TypeLits 33 | import GHC.TypeNats qualified as TN 34 | import Numeric.Fin.Internal 35 | import Unsafe.Coerce 36 | 37 | type role Index nominal nominal 38 | 39 | type family Length (as :: [i]) :: Nat where 40 | Length '[] = 0 41 | Length (x ': xs) = 1 + Length xs 42 | 43 | newtype Index (as :: [i]) (a :: i) = UnsafeIndex { fromIndex :: Int } 44 | deriving newtype (Eq, Ord, Show) 45 | 46 | pattern Index :: Int -> Index as i 47 | pattern Index i <- UnsafeIndex i 48 | {-# complete Index #-} 49 | 50 | len :: forall as. KnownLength as => Int 51 | len = int @(Length as) 52 | {-# inline len #-} 53 | 54 | liftFin :: forall i (as :: [i]). Fin (Length as) -> Some (Index as) 55 | liftFin = \(Fin i) -> Some (UnsafeIndex i) 56 | {-# inline liftFin #-} 57 | 58 | lowerFin :: forall i (as :: [i]) (a :: i). Index as a -> Fin (Length as) 59 | lowerFin = coerce 60 | {-# inline lowerFin #-} 61 | 62 | type role Index' nominal nominal 63 | data Index' :: [i] -> i -> Type where 64 | IZ' :: Index' (a:as) a 65 | IS' :: Index as a -> Index' (b:as) a 66 | 67 | type KnownLength (as :: [i]) = KnownNat (Length as) 68 | 69 | pattern IntIndex 70 | :: forall i (as :: [i]). KnownLength as 71 | => forall (a :: i). Index as a -> Int 72 | pattern IntIndex i <- (toIndex -> Just (Some i)) where 73 | IntIndex i = fromIndex i 74 | 75 | toIndex :: KnownLength is => Int -> Maybe (Some (Index is)) 76 | toIndex = fmap liftFin . toFin 77 | {-# inline toIndex #-} 78 | 79 | upIndex :: Index is i -> Index' is i 80 | upIndex (Index 0) = unsafeCoerce IZ' 81 | upIndex (Index n) = unsafeCoerce $ IS' $ UnsafeIndex (n - 1) 82 | {-# inline[0] upIndex #-} 83 | 84 | pattern IZ :: () => forall bs. as ~ (a:bs) => Index as a 85 | pattern IZ <- (upIndex -> IZ') where 86 | IZ = UnsafeIndex 0 87 | 88 | pattern IS :: () => forall bs. as ~ (b:bs) => Index bs a -> Index as a 89 | pattern IS n <- (upIndex -> IS' n) where 90 | IS n = UnsafeIndex (fromIndex n + 1) 91 | {-# complete IZ, IS #-} 92 | 93 | type role KnownIndex' nominal nominal 94 | data KnownIndex' :: [i] -> i -> Type where 95 | KnownIZ' :: KnownLength as => KnownIndex' (a:as) a 96 | KnownIS' :: KnownLength as => Index as a -> KnownIndex' (b:as) a 97 | 98 | upKnownIndex :: forall is i. KnownLength is => Index is i -> KnownIndex' is i 99 | upKnownIndex = case TN.someNatVal $ TN.natVal (Proxy :: Proxy (Length is)) - 1 of 100 | SomeNat (Proxy :: Proxy n) -> case unsafeCoerce Refl of 101 | (Refl :: n :~: Length js) -> case unsafeCoerce Refl of 102 | (Refl :: (is :~: (j ': js))) -> case unsafeCoerce Refl of 103 | (Refl :: (Length is :~: S (Length js))) -> \case 104 | UnsafeIndex 0 -> case unsafeCoerce Refl of 105 | (Refl :: j :~: i) -> (KnownIZ' :: KnownIndex' is i) 106 | UnsafeIndex n -> (KnownIS' $ UnsafeIndex (n-1) :: KnownIndex' is i) 107 | {-# inline[0] upKnownIndex #-} 108 | 109 | pattern KnownIZ :: KnownLength is => forall js j. (KnownLength js, is ~ j ': js) => Index is i 110 | pattern KnownIZ <- (upKnownIndex -> KnownIZ') where 111 | KnownIZ = UnsafeIndex 0 112 | 113 | pattern KnownIS :: KnownLength is => forall js j. (KnownLength js, is ~ j ': js) => Index js i -> Index is i 114 | pattern KnownIS n <- (upKnownIndex -> KnownIS' n) where 115 | KnownIS n = UnsafeIndex (fromIndex n + 1) 116 | {-# complete KnownIZ, KnownIS #-} 117 | 118 | 119 | instance GEq (Index is) where 120 | geq = \(Index i) (Index j) -> 121 | if i == j 122 | then Just (unsafeCoerce Refl) 123 | else Nothing 124 | {-# inline geq #-} 125 | 126 | instance GCompare (Index is) where 127 | gcompare = \(Index i) (Index j) -> 128 | case compare i j of 129 | LT -> GLT 130 | EQ -> unsafeCoerce GEQ 131 | GT -> GGT 132 | {-# inline gcompare #-} 133 | 134 | instance TestEquality (Index is) where 135 | testEquality = geq 136 | {-# inline testEquality #-} 137 | 138 | instance TestCoercion (Index is) where 139 | testCoercion = \x y -> repr <$> geq x y 140 | {-# inline testCoercion #-} 141 | 142 | instance GShow (Index as) where 143 | gshowsPrec = showsPrec 144 | {-# inline gshowsPrec #-} 145 | 146 | instance KnownLength as => GRead (Index as) where 147 | greadsPrec = \ d s -> first (liftFinWith mkGReadResult) <$> readsPrec d s 148 | 149 | liftFinWith :: forall i (as :: [i]) f. (forall (x :: i -> Type) (a :: i). x a -> f x) -> Fin (Length as) -> f (Index as) 150 | liftFinWith = \ f (Fin i) -> f (UnsafeIndex i) 151 | {-# inline liftFinWith #-} 152 | 153 | -------------------------------------------------------------------------------- /src/Data/Traversable/Confusing.hs: -------------------------------------------------------------------------------- 1 | {-# Language Safe #-} 2 | {-# Language NoDerivingVia #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2013-2016 Edward Kmett, Eric Mertens 6 | -- License : BSD-2-Clause OR Apache-2.0 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -- This code is derived from Eric Mertens' implementation of the @confusing@ 12 | -- combinator in @lens@. A description was later published in 13 | -- 14 | -- Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. . 15 | -- Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780 16 | 17 | module Data.Traversable.Confusing 18 | ( confusing, LensLike 19 | , iconfusing, IxLensLike 20 | , fconfusing, FLensLike 21 | , liftCurriedYoneda, yap 22 | , Curried (..), liftCurried, lowerCurried 23 | , Yoneda (..), liftYoneda, lowerYoneda 24 | ) where 25 | 26 | ------------------------------------------------------------------------------- 27 | -- Confusing 28 | ------------------------------------------------------------------------------- 29 | 30 | type LensLike f s t a b = (a -> f b) -> s -> f t 31 | 32 | -- | "Fuse" a 'Traversal' by reassociating all of the @('<*>')@ operations to the 33 | -- left and fusing all of the 'fmap' calls into one. This is particularly 34 | -- useful when constructing a 'Traversal' using operations from "GHC.Generics". 35 | -- 36 | -- Given a pair of 'Traversal's 'foo' and 'bar', 37 | -- 38 | -- @ 39 | -- 'confusing' (foo.bar) = foo.bar 40 | -- @ 41 | -- 42 | -- However, @foo@ and @bar@ are each going to use the 'Applicative' they are given. 43 | -- 44 | -- 'confusing' exploits the 'Yoneda' lemma to merge their separate uses of 'fmap' into a single 'fmap'. 45 | -- and it further exploits an interesting property of the right Kan lift (or 'Curried') to left associate 46 | -- all of the uses of @('<*>')@ to make it possible to fuse together more fmaps. 47 | -- 48 | -- This is particularly effective when the choice of functor 'f' is unknown at compile 49 | -- time or when the 'Traversal' @foo.bar@ in the above description is recursive or complex 50 | -- enough to prevent inlining. 51 | -- 52 | -- 'Control.Lens.Lens.fusing' is a version of this combinator suitable for fusing lenses. 53 | -- 54 | -- @ 55 | -- 'confusing' :: 'Traversal' s t a b -> 'Traversal' s t a b 56 | -- @ 57 | confusing :: Applicative f => LensLike (Curried (Yoneda f)) s t a b -> LensLike f s t a b 58 | confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f) 59 | {-# inline confusing #-} 60 | 61 | liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a 62 | liftCurriedYoneda = \fa -> Curried (`yap` fa) 63 | {-# inline liftCurriedYoneda #-} 64 | 65 | yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b 66 | yap = \(Yoneda k) fa -> Yoneda (\ab_r -> k (ab_r .) <*> fa) 67 | {-# inline yap #-} 68 | 69 | type IxLensLike f i s t a b = (i -> a -> f b) -> s -> f t 70 | 71 | iconfusing :: Applicative f => IxLensLike (Curried (Yoneda f)) i s t a b -> IxLensLike f i s t a b 72 | iconfusing t = \f -> lowerYoneda . lowerCurried . t (\i a -> liftCurriedYoneda (f i a)) 73 | {-# inline iconfusing #-} 74 | 75 | type FLensLike f s t a b = (forall x. a x -> f (b x)) -> s -> f t 76 | 77 | fconfusing :: Applicative f => FLensLike (Curried (Yoneda f)) s t a b -> FLensLike f s t a b 78 | fconfusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f) 79 | {-# inline fconfusing #-} 80 | 81 | ------------------------------------------------------------------------------- 82 | -- Curried 83 | ------------------------------------------------------------------------------- 84 | 85 | newtype Curried f a = Curried { runCurried :: forall r. f (a -> r) -> f r } 86 | 87 | instance Functor f => Functor (Curried f) where 88 | fmap f = \(Curried g) -> Curried (g . fmap (.f)) 89 | {-# inline fmap #-} 90 | 91 | instance Functor f => Applicative (Curried f) where 92 | pure = \a -> Curried (fmap ($ a)) 93 | {-# inline pure #-} 94 | (<*>) = \(Curried mf) (Curried ma) -> Curried (ma . mf . fmap (.)) 95 | {-# inline (<*>) #-} 96 | 97 | liftCurried :: Applicative f => f a -> Curried f a 98 | liftCurried = \fa -> Curried (<*> fa) 99 | {-# inline liftCurried #-} 100 | 101 | lowerCurried :: Applicative f => Curried f a -> f a 102 | lowerCurried = \(Curried f) -> f (pure id) 103 | {-# inline lowerCurried #-} 104 | 105 | ------------------------------------------------------------------------------- 106 | -- Yoneda 107 | ------------------------------------------------------------------------------- 108 | 109 | newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b } 110 | 111 | liftYoneda :: Functor f => f a -> Yoneda f a 112 | liftYoneda = \a -> Yoneda (\f -> fmap f a) 113 | {-# inline liftYoneda #-} 114 | 115 | lowerYoneda :: Yoneda f a -> f a 116 | lowerYoneda = \(Yoneda f) -> f id 117 | {-# inline lowerYoneda #-} 118 | 119 | instance Functor (Yoneda f) where 120 | fmap f = \ m -> Yoneda (\k -> runYoneda m (k . f)) 121 | {-# inline fmap #-} 122 | 123 | instance Applicative f => Applicative (Yoneda f) where 124 | pure = \ a -> Yoneda (\f -> pure (f a)) 125 | {-# inline pure #-} 126 | (<*>) = \ (Yoneda m) (Yoneda n) -> Yoneda (\f -> m (f .) <*> n id) 127 | {-# inline (<*>) #-} 128 | 129 | -------------------------------------------------------------------------------- /src/Data/HKD/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# Language Trustworthy #-} 2 | {-# Language GeneralizedNewtypeDeriving #-} 3 | {-# options_ghc -Wno-orphans #-} 4 | {-# options_haddock hide #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2021 Edward Kmett, 8 | -- License : BSD-2-Clause OR Apache-2.0 9 | -- Maintainer : Edward Kmett 10 | -- Stability : provisional 11 | -- Portability : non-portable 12 | 13 | module Data.HKD.Orphans () where 14 | 15 | import Data.Coerce 16 | import Data.Functor.Classes 17 | import Data.GADT.Compare 18 | import Data.Type.Coercion 19 | import Data.Type.Equality 20 | import GHC.Generics 21 | import Text.Read as Read 22 | -- import GHC.Read (readField) 23 | 24 | -- move to base-orphans 25 | 26 | instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where 27 | liftEq f (a :*: b) (a' :*: b') = liftEq f a a' && liftEq f b b' 28 | {-# inline liftEq #-} 29 | 30 | instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where 31 | liftCompare f (a :*: b) (a' :*: b') = liftCompare f a a' <> liftCompare f b b' 32 | {-# inline liftCompare #-} 33 | 34 | instance (Show1 f, Show1 g) => Show1 (f :*: g) where 35 | -- infixr 6 36 | liftShowsPrec f l d (x :*: y) = 37 | showParen (d > 6) $ 38 | liftShowsPrec f l 7 x . 39 | showString " :*: " . 40 | liftShowsPrec f l 6 y 41 | 42 | instance (Read1 f, Read1 g) => Read1 (f :*: g) where 43 | liftReadPrec f fl = parens $ 44 | Read.prec 6 $ do 45 | u <- step (liftReadPrec f fl) 46 | Symbol ":*:" <- lexP 47 | (u :*:) <$> step (liftReadPrec f fl) 48 | 49 | deriving newtype instance Eq1 f => Eq1 (M1 i c f) 50 | deriving newtype instance Ord1 f => Ord1 (M1 i c f) 51 | deriving newtype instance Show1 f => Show1 (M1 i c f) 52 | deriving newtype instance Read1 f => Read1 (M1 i c f) 53 | 54 | instance Eq c => Eq1 (K1 i c) where 55 | liftEq _ (K1 x) (K1 y) = x == y 56 | 57 | instance Ord c => Ord1 (K1 i c) where 58 | liftCompare _ (K1 x) (K1 y) = compare x y 59 | 60 | instance Show c => Show1 (K1 i c) where 61 | liftShowsPrec _ _ = showsPrec 62 | 63 | instance Read c => Read1 (K1 i c) where 64 | liftReadPrec _ _ = readPrec 65 | 66 | instance Eq1 Par1 where 67 | liftEq f = coerce f 68 | 69 | instance Ord1 Par1 where 70 | liftCompare f = coerce f 71 | 72 | instance Show1 Par1 where 73 | liftShowsPrec f _ d (Par1 x) = showParen (d > 10) $ 74 | showString "Par1 " . f 11 x 75 | -- showString "Par1 {unPar1 = " . f d x . showString "}" 76 | 77 | -- TODO: use Par1 {unPar1 = ... } 78 | instance Read1 Par1 where 79 | liftReadPrec f _ = parens $ do 80 | Read.prec 10 $ do 81 | Ident "Par1" <- lexP 82 | Par1 <$> step f 83 | {- 84 | Punc "{" <- lexP 85 | field <- readField "unPar1" (step f) 86 | Punc "}" <- lexP 87 | pure $ Par1 field 88 | -} 89 | 90 | -- move to @some@ 91 | 92 | instance Semigroup (GOrdering a b) where 93 | GLT <> _ = GLT 94 | GEQ <> x = x 95 | GGT <> _ = GGT 96 | 97 | instance a ~ b => Monoid (GOrdering a b) where 98 | mempty = GEQ 99 | 100 | {- 101 | instance (GEq f, GEq g) => GEq (f :+: g) where 102 | geq (L1 x) (L1 y) = geq x y 103 | geq (R1 x) (R1 y) = geq x y 104 | geq _ _ = Nothing 105 | {-# inline geq #-} 106 | -} 107 | 108 | instance GEq V1 where 109 | geq = \case 110 | 111 | {- 112 | instance (GEq f, GEq g) => GEq (f :*: g) where 113 | geq = \(a :*: b) (c :*: d) -> geq a c *> geq b d 114 | {-# inline geq #-} 115 | -} 116 | 117 | instance GEq f => GEq (M1 i c f) where 118 | geq :: forall a b. M1 i c f a -> M1 i c f b -> Maybe (a :~: b) 119 | geq = coerce (geq :: f a -> f b -> Maybe (a :~: b)) 120 | 121 | instance GEq f => GEq (Rec1 f) where 122 | geq :: forall a b. Rec1 f a -> Rec1 f b -> Maybe (a :~: b) 123 | geq = coerce (geq :: f a -> f b -> Maybe (a :~: b)) 124 | 125 | -- move to @base@ or @base-orphans@ 126 | 127 | instance (TestEquality f, TestEquality g) => TestEquality (f :+: g) where 128 | testEquality (L1 x) (L1 y) = testEquality x y 129 | testEquality (R1 x) (R1 y) = testEquality x y 130 | testEquality _ _ = Nothing 131 | {-# inline testEquality #-} 132 | 133 | instance (TestEquality f, TestEquality g) => TestEquality (f :*: g) where 134 | testEquality = \(a :*: b) (c :*: d) -> testEquality a c *> testEquality b d 135 | {-# inline testEquality #-} 136 | 137 | instance TestEquality f => TestEquality (M1 i c f) where 138 | testEquality :: forall a b. M1 i c f a -> M1 i c f b -> Maybe (a :~: b) 139 | testEquality = coerce (testEquality :: f a -> f b -> Maybe (a :~: b)) 140 | 141 | instance TestEquality f => TestEquality (Rec1 f) where 142 | testEquality :: forall a b. Rec1 f a -> Rec1 f b -> Maybe (a :~: b) 143 | testEquality = coerce (testEquality :: f a -> f b -> Maybe (a :~: b)) 144 | 145 | instance TestEquality V1 where 146 | testEquality = \case 147 | 148 | instance (TestCoercion f, TestCoercion g) => TestCoercion (f :+: g) where 149 | testCoercion (L1 x) (L1 y) = testCoercion x y 150 | testCoercion (R1 x) (R1 y) = testCoercion x y 151 | testCoercion _ _ = Nothing 152 | {-# inline testCoercion #-} 153 | 154 | instance (TestCoercion f, TestCoercion g) => TestCoercion (f :*: g) where 155 | testCoercion = \(a :*: b) (c :*: d) -> testCoercion a c *> testCoercion b d 156 | {-# inline testCoercion #-} 157 | 158 | instance TestCoercion f => TestCoercion (M1 i c f) where 159 | testCoercion :: forall a b. M1 i c f a -> M1 i c f b -> Maybe (Coercion a b) 160 | testCoercion = coerce (testCoercion :: f a -> f b -> Maybe (Coercion a b)) 161 | 162 | instance TestCoercion f => TestCoercion (Rec1 f) where 163 | testCoercion :: forall a b. Rec1 f a -> Rec1 f b -> Maybe (Coercion a b) 164 | testCoercion = coerce (testCoercion :: f a -> f b -> Maybe (Coercion a b)) 165 | 166 | instance TestCoercion V1 where 167 | testCoercion = \case 168 | -------------------------------------------------------------------------------- /LICENSES/Apache-2.0.txt: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. 10 | 11 | "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. 12 | 13 | "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. 14 | 15 | "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. 16 | 17 | "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. 18 | 19 | "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. 20 | 21 | "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). 22 | 23 | "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. 24 | 25 | "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." 26 | 27 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 28 | 29 | 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 30 | 31 | 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 32 | 33 | 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: 34 | 35 | (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and 36 | 37 | (b) You must cause any modified files to carry prominent notices stating that You changed the files; and 38 | 39 | (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and 40 | 41 | (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. 42 | 43 | You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 44 | 45 | 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 46 | 47 | 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 48 | 49 | 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 50 | 51 | 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 52 | 53 | 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. 54 | 55 | END OF TERMS AND CONDITIONS 56 | 57 | APPENDIX: How to apply the Apache License to your work. 58 | 59 | To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. 60 | 61 | Copyright [yyyy] [name of copyright owner] 62 | 63 | Licensed under the Apache License, Version 2.0 (the "License"); 64 | you may not use this file except in compliance with the License. 65 | You may obtain a copy of the License at 66 | 67 | http://www.apache.org/licenses/LICENSE-2.0 68 | 69 | Unless required by applicable law or agreed to in writing, software 70 | distributed under the License is distributed on an "AS IS" BASIS, 71 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 72 | See the License for the specific language governing permissions and 73 | limitations under the License. -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | Licensed under either of 4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) 5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) 6 | at your option. 7 | 8 | ## BSD 2-Clause License 9 | 10 | - Copyright 2011-2021 Edward Kmett 11 | - Copyright 2018-2021 Aaron Vargo 12 | - Copyright 2021 Oleg Grenrus 13 | 14 | All rights reserved. 15 | 16 | Redistribution and use in source and binary forms, with or without 17 | modification, are permitted provided that the following conditions 18 | are met: 19 | 20 | 1. Redistributions of source code must retain the above copyright 21 | notice, this list of conditions and the following disclaimer. 22 | 23 | 2. Redistributions in binary form must reproduce the above copyright 24 | notice, this list of conditions and the following disclaimer in the 25 | documentation and/or other materials provided with the distribution. 26 | 27 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 28 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 29 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 30 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 31 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 32 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 33 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 34 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 35 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 36 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 37 | POSSIBILITY OF SUCH DAMAGE. 38 | 39 | ## Apache License 40 | 41 | _Version 2.0, January 2004_ 42 | _<>_ 43 | 44 | ### Terms and Conditions for use, reproduction, and distribution 45 | 46 | #### 1. Definitions 47 | 48 | “License” shall mean the terms and conditions for use, reproduction, and 49 | distribution as defined by Sections 1 through 9 of this document. 50 | 51 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 52 | owner that is granting the License. 53 | 54 | “Legal Entity” shall mean the union of the acting entity and all other entities 55 | that control, are controlled by, or are under common control with that entity. 56 | For the purposes of this definition, “control” means **(i)** the power, direct or 57 | indirect, to cause the direction or management of such entity, whether by 58 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 59 | outstanding shares, or **(iii)** beneficial ownership of such entity. 60 | 61 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 62 | permissions granted by this License. 63 | 64 | “Source” form shall mean the preferred form for making modifications, including 65 | but not limited to software source code, documentation source, and configuration 66 | files. 67 | 68 | “Object” form shall mean any form resulting from mechanical transformation or 69 | translation of a Source form, including but not limited to compiled object code, 70 | generated documentation, and conversions to other media types. 71 | 72 | “Work” shall mean the work of authorship, whether in Source or Object form, made 73 | available under the License, as indicated by a copyright notice that is included 74 | in or attached to the work (an example is provided in the Appendix below). 75 | 76 | “Derivative Works” shall mean any work, whether in Source or Object form, that 77 | is based on (or derived from) the Work and for which the editorial revisions, 78 | annotations, elaborations, or other modifications represent, as a whole, an 79 | original work of authorship. For the purposes of this License, Derivative Works 80 | shall not include works that remain separable from, or merely link (or bind by 81 | name) to the interfaces of, the Work and Derivative Works thereof. 82 | 83 | “Contribution” shall mean any work of authorship, including the original version 84 | of the Work and any modifications or additions to that Work or Derivative Works 85 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 86 | by the copyright owner or by an individual or Legal Entity authorized to submit 87 | on behalf of the copyright owner. For the purposes of this definition, 88 | “submitted” means any form of electronic, verbal, or written communication sent 89 | to the Licensor or its representatives, including but not limited to 90 | communication on electronic mailing lists, source code control systems, and 91 | issue tracking systems that are managed by, or on behalf of, the Licensor for 92 | the purpose of discussing and improving the Work, but excluding communication 93 | that is conspicuously marked or otherwise designated in writing by the copyright 94 | owner as “Not a Contribution.” 95 | 96 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 97 | of whom a Contribution has been received by Licensor and subsequently 98 | incorporated within the Work. 99 | 100 | #### 2. Grant of Copyright License 101 | 102 | Subject to the terms and conditions of this License, each Contributor hereby 103 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 104 | irrevocable copyright license to reproduce, prepare Derivative Works of, 105 | publicly display, publicly perform, sublicense, and distribute the Work and such 106 | Derivative Works in Source or Object form. 107 | 108 | #### 3. Grant of Patent License 109 | 110 | Subject to the terms and conditions of this License, each Contributor hereby 111 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 112 | irrevocable (except as stated in this section) patent license to make, have 113 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 114 | such license applies only to those patent claims licensable by such Contributor 115 | that are necessarily infringed by their Contribution(s) alone or by combination 116 | of their Contribution(s) with the Work to which such Contribution(s) was 117 | submitted. If You institute patent litigation against any entity (including a 118 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 119 | Contribution incorporated within the Work constitutes direct or contributory 120 | patent infringement, then any patent licenses granted to You under this License 121 | for that Work shall terminate as of the date such litigation is filed. 122 | 123 | #### 4. Redistribution 124 | 125 | You may reproduce and distribute copies of the Work or Derivative Works thereof 126 | in any medium, with or without modifications, and in Source or Object form, 127 | provided that You meet the following conditions: 128 | 129 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 130 | this License; and 131 | * **(b)** You must cause any modified files to carry prominent notices stating that You 132 | changed the files; and 133 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 134 | all copyright, patent, trademark, and attribution notices from the Source form 135 | of the Work, excluding those notices that do not pertain to any part of the 136 | Derivative Works; and 137 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 138 | Derivative Works that You distribute must include a readable copy of the 139 | attribution notices contained within such NOTICE file, excluding those notices 140 | that do not pertain to any part of the Derivative Works, in at least one of the 141 | following places: within a NOTICE text file distributed as part of the 142 | Derivative Works; within the Source form or documentation, if provided along 143 | with the Derivative Works; or, within a display generated by the Derivative 144 | Works, if and wherever such third-party notices normally appear. The contents of 145 | the NOTICE file are for informational purposes only and do not modify the 146 | License. You may add Your own attribution notices within Derivative Works that 147 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 148 | provided that such additional attribution notices cannot be construed as 149 | modifying the License. 150 | 151 | You may add Your own copyright statement to Your modifications and may provide 152 | additional or different license terms and conditions for use, reproduction, or 153 | distribution of Your modifications, or for any such Derivative Works as a whole, 154 | provided Your use, reproduction, and distribution of the Work otherwise complies 155 | with the conditions stated in this License. 156 | 157 | #### 5. Submission of Contributions 158 | 159 | Unless You explicitly state otherwise, any Contribution intentionally submitted 160 | for inclusion in the Work by You to the Licensor shall be under the terms and 161 | conditions of this License, without any additional terms or conditions. 162 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 163 | any separate license agreement you may have executed with Licensor regarding 164 | such Contributions. 165 | 166 | #### 6. Trademarks 167 | 168 | This License does not grant permission to use the trade names, trademarks, 169 | service marks, or product names of the Licensor, except as required for 170 | reasonable and customary use in describing the origin of the Work and 171 | reproducing the content of the NOTICE file. 172 | 173 | #### 7. Disclaimer of Warranty 174 | 175 | Unless required by applicable law or agreed to in writing, Licensor provides the 176 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 177 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 178 | including, without limitation, any warranties or conditions of TITLE, 179 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 180 | solely responsible for determining the appropriateness of using or 181 | redistributing the Work and assume any risks associated with Your exercise of 182 | permissions under this License. 183 | 184 | #### 8. Limitation of Liability 185 | 186 | In no event and under no legal theory, whether in tort (including negligence), 187 | contract, or otherwise, unless required by applicable law (such as deliberate 188 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 189 | liable to You for damages, including any direct, indirect, special, incidental, 190 | or consequential damages of any character arising as a result of this License or 191 | out of the use or inability to use the Work (including but not limited to 192 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 193 | any and all other commercial damages or losses), even if such Contributor has 194 | been advised of the possibility of such damages. 195 | 196 | #### 9. Accepting Warranty or Additional Liability 197 | 198 | While redistributing the Work or Derivative Works thereof, You may choose to 199 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 200 | other liability obligations and/or rights consistent with this License. However, 201 | in accepting such obligations, You may act only on Your own behalf and on Your 202 | sole responsibility, not on behalf of any other Contributor, and only if You 203 | agree to indemnify, defend, and hold each Contributor harmless for any liability 204 | incurred by, or claims asserted against, such Contributor by reason of your 205 | accepting any such warranty or additional liability. 206 | 207 | _END OF TERMS AND CONDITIONS_ 208 | 209 | ### APPENDIX: How to apply the Apache License to your work 210 | 211 | To apply the Apache License to your work, attach the following boilerplate 212 | notice, with the fields enclosed by brackets `[]` replaced with your own 213 | identifying information. (Don't include the brackets!) The text should be 214 | enclosed in the appropriate comment syntax for the file format. We also 215 | recommend that a file or class name and description of purpose be included on 216 | the same “printed page” as the copyright notice for easier identification within 217 | third-party archives. 218 | 219 | Copyright [yyyy] [name of copyright owner] 220 | 221 | Licensed under the Apache License, Version 2.0 (the "License"); 222 | you may not use this file except in compliance with the License. 223 | You may obtain a copy of the License at 224 | 225 | http://www.apache.org/licenses/LICENSE-2.0 226 | 227 | Unless required by applicable law or agreed to in writing, software 228 | distributed under the License is distributed on an "AS IS" BASIS, 229 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 230 | See the License for the specific language governing permissions and 231 | limitations under the License. 232 | 233 | -------------------------------------------------------------------------------- /src/Data/HKD/Contravariant.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language GeneralizedNewtypeDeriving #-} 3 | {-# Language Trustworthy #-} 4 | 5 | -- | 6 | -- Copyright : (c) 2021 Edward Kmett 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer: Edward Kmett 9 | -- Stability : experimental 10 | -- Portability: non-portable 11 | -- 12 | -- Contravariant "Higher-Kinded Data" 13 | 14 | module Data.HKD.Contravariant 15 | ( FContravariant(..) 16 | , FSemidivisible(..) 17 | , FDivisible(..) 18 | , fdivided 19 | , fconquered 20 | , fliftDiv 21 | , FSemidecidable(..) 22 | , FDecidable 23 | , flost 24 | , fchosen 25 | , FSemideciding(..) 26 | --, FDeciding(..) 27 | -- * Types 28 | , FEquivalence(..) 29 | , FComparison(..) 30 | , FOp(..) 31 | ) where 32 | 33 | import Control.Applicative 34 | import Control.Applicative.Backwards 35 | import Data.Coerce 36 | import Data.Functor.Compose 37 | import Data.Functor.Product 38 | import Data.Functor.Reverse 39 | import Data.Functor.Sum 40 | import Data.GADT.Compare 41 | import Data.HKD.Classes 42 | import Data.Kind 43 | import Data.Proxy 44 | import Data.Function.Coerce 45 | import Data.Type.Equality 46 | import GHC.Generics 47 | import qualified Data.Monoid as Monoid 48 | 49 | ------------------------------------------------------------------------------- 50 | -- FContravariant 51 | ------------------------------------------------------------------------------- 52 | 53 | class FContravariant (t :: (k -> Type) -> Type) where 54 | fcontramap :: (f ~> g) -> t g -> t f 55 | default fcontramap :: (Generic1 t, FContravariant (Rep1 t)) => (f ~> g) -> t g -> t f 56 | fcontramap f = to1 . fcontramap f . from1 57 | {-# inline fcontramap #-} 58 | 59 | instance FContravariant Proxy where 60 | fcontramap _ Proxy = Proxy 61 | {-# inline fcontramap #-} 62 | 63 | instance FContravariant (Const a) where 64 | fcontramap _ (Const a) = Const a 65 | {-# inline fcontramap #-} 66 | 67 | instance (Functor f, FContravariant g) => FContravariant (Compose f g) where 68 | fcontramap f = Compose #. fmap (fcontramap f) .# getCompose 69 | {-# inline fcontramap #-} 70 | 71 | instance (FContravariant f, FContravariant g) => FContravariant (Product f g) where 72 | fcontramap f (Pair g h) = Pair (fcontramap f g) (fcontramap f h) 73 | {-# inline fcontramap #-} 74 | 75 | instance (FContravariant f, FContravariant g) => FContravariant (Sum f g) where 76 | fcontramap f (InL g) = InL (fcontramap f g) 77 | fcontramap f (InR h) = InR (fcontramap f h) 78 | {-# inline fcontramap #-} 79 | 80 | instance FContravariant (K1 i a) where 81 | fcontramap _ = coerce 82 | {-# inline fcontramap #-} 83 | 84 | deriving newtype instance FContravariant f => FContravariant (M1 i c f) 85 | deriving newtype instance FContravariant f => FContravariant (Rec1 f) 86 | 87 | instance FContravariant U1 where 88 | fcontramap _ U1 = U1 89 | {-# inline fcontramap #-} 90 | 91 | instance FContravariant V1 where 92 | fcontramap _ = \case 93 | {-# inline fcontramap #-} 94 | 95 | instance (Functor f, FContravariant g) => FContravariant (f :.: g) where 96 | fcontramap f = Comp1 #. fmap (fcontramap f) .# unComp1 97 | {-# inline fcontramap #-} 98 | 99 | instance (FContravariant f, FContravariant g) => FContravariant (f :*: g) where 100 | fcontramap f (g :*: h) = fcontramap f g :*: fcontramap f h 101 | {-# inline fcontramap #-} 102 | 103 | instance (FContravariant f, FContravariant g) => FContravariant (f :+: g) where 104 | fcontramap f (L1 g) = L1 (fcontramap f g) 105 | fcontramap f (R1 h) = R1 (fcontramap f h) 106 | {-# inline fcontramap #-} 107 | 108 | deriving newtype instance FContravariant f => FContravariant (Backwards f) 109 | deriving newtype instance FContravariant f => FContravariant (Reverse f) 110 | deriving newtype instance FContravariant f => FContravariant (Monoid.Alt f) 111 | deriving newtype instance FContravariant f => FContravariant (Monoid.Ap f) 112 | 113 | newtype FEquivalence a = FEquivalence 114 | { getFEquivalence :: forall x y. a x -> a y -> Maybe (x :~: y) 115 | } 116 | 117 | instance FContravariant FEquivalence where 118 | fcontramap f (FEquivalence g) = FEquivalence \i j -> g (f i) (f j) 119 | {-# inline fcontramap #-} 120 | 121 | newtype FComparison a = FComparison 122 | { getFComparison :: forall x y. a x -> a y -> GOrdering x y 123 | } 124 | 125 | instance FContravariant FComparison where 126 | fcontramap f (FComparison g) = FComparison \i j -> g (f i) (f j) 127 | {-# inline fcontramap #-} 128 | 129 | newtype FOp b f = FOp { getFOp :: forall x. f x -> b } 130 | 131 | instance FContravariant (FOp b) where 132 | fcontramap f (FOp g) = FOp (g . f) 133 | {-# inline fcontramap #-} 134 | 135 | class FContravariant f => FSemidivisible f where 136 | fdivide :: (a ~> b :*: c) -> f b -> f c -> f a 137 | 138 | class FSemidivisible f => FDivisible f where 139 | fconquer :: f a 140 | 141 | fdivided :: FSemidivisible f => f a -> f b -> f (a :*: b) 142 | fdivided = fdivide id 143 | {-# inline fdivided #-} 144 | 145 | fconquered :: FDivisible f => f U1 146 | fconquered = fconquer 147 | {-# inline fconquered #-} 148 | 149 | fliftDiv :: FDivisible f => (a ~> b) -> f b -> f a 150 | fliftDiv f = fdivide ((:*:) U1 . f) fconquer 151 | {-# inline fliftDiv #-} 152 | 153 | class FSemidivisible f => FSemidecidable f where 154 | fchoose :: (a ~> (b :+: c)) -> f b -> f c -> f a 155 | flose :: (a ~> V1) -> f a 156 | 157 | class (FDivisible f, FSemidecidable f) => FDecidable f 158 | instance (FDivisible f, FSemidecidable f) => FDecidable f 159 | 160 | flost :: FDecidable f => f V1 161 | flost = flose id 162 | {-# inline flost #-} 163 | 164 | fchosen :: FSemidecidable f => f a -> f b -> f (a :+: b) 165 | fchosen = fchoose id 166 | {-# inline fchosen #-} 167 | 168 | -- * FDivisible Instances 169 | -- 170 | -- FEquivalence a = (forall x y. a x -> a y -> Maybe (x :~: y) 171 | 172 | instance FSemidivisible FEquivalence where 173 | fdivide f g h = FEquivalence $ \a a' -> case f a of 174 | b :*: c -> case f a' of 175 | b' :*: c' -> getFEquivalence g b b' *> getFEquivalence h c c' 176 | {-# inline fdivide #-} 177 | 178 | instance FSemidecidable FEquivalence where 179 | fchoose f g h = FEquivalence $ \a a' -> case f a of 180 | L1 b -> case f a' of 181 | L1 b' -> getFEquivalence g b b' 182 | _ -> Nothing 183 | R1 c -> case f a' of 184 | R1 c' -> getFEquivalence h c c' 185 | _ -> Nothing 186 | {-# inline fchoose #-} 187 | 188 | flose f = FEquivalence $ \a -> case f a of 189 | {-# inline flose #-} 190 | 191 | instance FSemidivisible FComparison where 192 | fdivide = \f g h -> FComparison $ \a a' -> case f a of 193 | b :*: c -> case f a' of 194 | b' :*: c' -> case getFComparison g b b' of 195 | GLT -> GLT 196 | GEQ -> getFComparison h c c' 197 | GGT -> GGT 198 | {-# inline fdivide #-} 199 | 200 | instance FSemidecidable FComparison where 201 | fchoose = \f g h -> FComparison $ \a a' -> case f a of 202 | L1 b -> case f a' of 203 | L1 b' -> getFComparison g b b' 204 | _ -> GLT 205 | R1 c -> case f a' of 206 | R1 c' -> getFComparison h c c' 207 | _ -> GGT 208 | {-# inline fchoose #-} 209 | 210 | flose = \f -> FComparison $ \a -> case f a of 211 | {-# inline flose #-} 212 | 213 | instance Semigroup b => FSemidivisible (FOp b) where 214 | fdivide = \f g h -> FOp $ \x -> case f x of 215 | b :*: c -> getFOp g b <> getFOp h c 216 | {-# inline fdivide #-} 217 | 218 | instance Monoid b => FDivisible (FOp b) where 219 | fconquer = FOp $ \_ -> mempty 220 | {-# inline fconquer #-} 221 | 222 | instance Semigroup c => FSemidivisible (K1 i c) where 223 | fdivide = \_ (K1 m) (K1 n) -> K1 (m <> n) 224 | {-# inline fdivide #-} 225 | 226 | instance Monoid c => FDivisible (K1 i c) where 227 | fconquer = K1 mempty 228 | {-# inline fconquer #-} 229 | 230 | instance FSemidivisible U1 where 231 | fdivide = \_ U1 -> coerce 232 | {-# inline fdivide #-} 233 | 234 | instance FDivisible U1 where 235 | fconquer = U1 236 | {-# inline fconquer #-} 237 | 238 | instance FSemidivisible f => FSemidivisible (Rec1 f) where 239 | fdivide = \f l -> Rec1 #. fdivide f (unRec1 l) .# unRec1 240 | {-# inline fdivide #-} 241 | 242 | instance FDivisible f => FDivisible (Rec1 f) where 243 | fconquer = Rec1 fconquer 244 | {-# inline fconquer #-} 245 | 246 | instance FSemidivisible f => FSemidivisible (M1 i c f) where 247 | fdivide = \f (M1 l) -> M1 #. fdivide f l .# unM1 248 | {-# inline fdivide #-} 249 | 250 | instance FDivisible f => FDivisible (M1 i c f) where 251 | fconquer = M1 fconquer 252 | {-# inline fconquer #-} 253 | 254 | instance (FSemidivisible f, FSemidivisible g) => FSemidivisible (f :*: g) where 255 | fdivide = \f (l1 :*: r1) (l2 :*: r2) -> fdivide f l1 l2 :*: fdivide f r1 r2 256 | {-# inline fdivide #-} 257 | 258 | instance (FDivisible f, FDivisible g) => FDivisible (f :*: g) where 259 | fconquer = fconquer :*: fconquer 260 | {-# inline fconquer #-} 261 | 262 | -- | only needs Semiapplicative 263 | instance (Applicative f, FSemidivisible g) => FSemidivisible (f :.: g) where 264 | fdivide = \f (Comp1 l) (Comp1 r) -> Comp1 (liftA2 (fdivide f) l r) 265 | {-# inline fdivide #-} 266 | 267 | instance (Applicative f, FDivisible g) => FDivisible (f :.: g) where 268 | fconquer = Comp1 $ pure fconquer 269 | {-# inline fconquer #-} 270 | 271 | -- * FDecidable 272 | 273 | instance Semigroup b => FSemidecidable (FOp b) where 274 | fchoose = \ f g h -> FOp $ \x -> case f x of 275 | L1 b -> getFOp g b 276 | R1 b -> getFOp h b 277 | {-# inline fchoose #-} 278 | 279 | flose = \f -> FOp (\x -> case f x of) 280 | {-# inline flose #-} 281 | 282 | instance FSemidecidable U1 where 283 | fchoose = \_ U1 -> coerce 284 | {-# inline fchoose #-} 285 | 286 | flose = \_ -> U1 287 | {-# inline flose #-} 288 | 289 | instance FSemidecidable f => FSemidecidable (Rec1 f) where 290 | fchoose = \f l -> Rec1 #. fchoose f (unRec1 l) .# unRec1 291 | {-# inline fchoose #-} 292 | 293 | flose = \f -> Rec1 $ flose f 294 | {-# inline flose #-} 295 | 296 | instance FSemidecidable f => FSemidecidable (M1 i c f) where 297 | fchoose = \f l -> M1 #. fchoose f (unM1 l) .# unM1 298 | {-# inline fchoose #-} 299 | 300 | flose = \f -> M1 $ flose f 301 | {-# inline flose #-} 302 | 303 | instance (FSemidecidable f, FSemidecidable g) => FSemidecidable (f :*: g) where 304 | fchoose = \f (l1 :*: r1) (l2 :*: r2) -> fchoose f l1 l2 :*: fchoose f r1 r2 305 | {-# inline fchoose #-} 306 | 307 | flose = \f -> flose f :*: flose f 308 | {-# inline flose #-} 309 | 310 | -- | only needs Semiapplicative 311 | instance (Applicative f, FSemidecidable g) => FSemidecidable (f :.: g) where 312 | fchoose = \f l -> Comp1 #. liftA2 (fchoose f) (unComp1 l) .# unComp1 313 | {-# inline fchoose #-} 314 | 315 | flose = \x -> Comp1 $ pure $ flose x 316 | {-# inline flose #-} 317 | 318 | class FSemideciding q t where 319 | fsemideciding 320 | :: FSemidecidable f 321 | => (s ~> t) 322 | -> (forall b. q b => f b) 323 | -> f s 324 | default fsemideciding 325 | :: (Generic1 t, FSemideciding q (Rep1 t), FSemidecidable f) 326 | => (s ~> t) 327 | -> (forall b. q b => f b) 328 | -> f s 329 | fsemideciding = \ st -> fsemideciding @q (from1 . st) 330 | {-# inline fsemideciding #-} 331 | 332 | instance (FSemideciding q s, FSemideciding q t) => FSemideciding q (Product s t) 333 | instance (FSemideciding q s, FSemideciding q t) => FSemideciding q (Sum s t) 334 | #if __GLASGOW_HASKELL__ >= 808 335 | deriving newtype instance FSemideciding q f => FSemideciding q (Monoid.Alt f) 336 | deriving newtype instance FSemideciding q f => FSemideciding q (Monoid.Ap f) 337 | -- deriving newtype instance FSemideciding q f => FSemideciding q (Backwards f) 338 | -- deriving newtype instance FSemideciding q f => FSemideciding q (Reverse f) 339 | #else 340 | -- Using GeneralizedNewtypeDeriving with GHC 8.6 won't work due to what is 341 | -- presumably an old typechecker bug. Sigh. See ekmett/hkd#1. 342 | instance FSemideciding q f => FSemideciding q (Monoid.Alt f) where 343 | fsemideciding = \k f -> fsemideciding @q (Monoid.Alt #. k) f 344 | 345 | instance FSemideciding q f => FSemideciding q (Monoid.Ap f) where 346 | fsemideciding = \k f -> fsemideciding @q (Monoid.Ap #. k) f 347 | 348 | -- instance FSemideciding q f => FSemideciding q (Backwards f) where 349 | -- fsemideciding = \k f -> fsemideciding @q (Backwards #. k) f 350 | -- 351 | -- instance FSemideciding q f => FSemideciding q (Reverse f) where 352 | -- fsemideciding = \k f -> fsemideciding @q (Reverse #. k) f 353 | #endif 354 | 355 | instance (FSemideciding q s, FSemideciding q t) => FSemideciding q (s :*: t) where 356 | fsemideciding = \k f -> fdivide k (fsemideciding @q id f) (fsemideciding @q id f) 357 | 358 | instance (FSemideciding q s, FSemideciding q t) => FSemideciding q (s :+: t) where 359 | fsemideciding = \k f -> fchoose k (fsemideciding @q id f) (fsemideciding @q id f) 360 | 361 | instance FSemideciding q V1 where 362 | fsemideciding = \k _ -> flose $ \x -> case k x of 363 | 364 | instance FSemideciding q f => FSemideciding q (M1 i c f) where 365 | fsemideciding = \k f -> fsemideciding @q (M1 #. k) f 366 | 367 | -- instance q f => FSemideciding q (Rec1 f) where 368 | -- fsemideciding k f = fcontramap (unRec1 #. k) f 369 | 370 | instance FSemideciding q f => FSemideciding q (Rec1 f) where 371 | fsemideciding = \k f -> fsemideciding @q (unRec1 #. k) f 372 | 373 | instance q (Const c) => FSemideciding q (K1 i c) where 374 | fsemideciding k f = fcontramap ((Const . unK1) #. k) f 375 | 376 | --class FSemideciding q t => FDeciding q t where 377 | -- fdeciding :: FSemidecidable f => p q -> (forall b. q b => f b) -> f (t a) 378 | -------------------------------------------------------------------------------- /src/Data/HKD.hs: -------------------------------------------------------------------------------- 1 | {-# language Trustworthy #-} 2 | {-# Language GeneralizedNewtypeDeriving #-} 3 | 4 | -- | 5 | -- Copyright : (c) 2019-2021 Edward Kmett 6 | -- (c) 2019 Oleg Grenrus 7 | -- (c) 2017-2021 Aaron Vargo 8 | -- License : BSD-2-Clause OR Apache-2.0 9 | -- Maintainer: Edward Kmett 10 | -- Stability : experimental 11 | -- Portability: non-portable 12 | -- 13 | -- "Higher-Kinded Data" such as it is 14 | -- 15 | -- Simple usage: 16 | -- 17 | -- @ 18 | -- data Record f = Record 19 | -- { fieldInt :: f Int 20 | -- , fieldString :: f String 21 | -- , fieldSome :: 'Some' f 22 | -- } deriving ('Generic1', 'FFunctor', 'FFoldable', 'FTraversable') 23 | -- @ 24 | -- 25 | -- Generically derived 'FApply' and 'FApplicative': 26 | -- 27 | -- @ 28 | -- data Record f = Record 29 | -- { fieldInt :: f Int 30 | -- , fieldString :: f String 31 | -- } deriving ('Generic1', 'FApply', 'FApplicative') 32 | -- @ 33 | module Data.HKD 34 | ( 35 | -- * "Natural" transformations 36 | type (~>) 37 | -- * Functor 38 | , FFunctor(..) 39 | , gffmap 40 | -- * Foldable 41 | , FFoldable(..) 42 | , gffoldMap 43 | , flength 44 | , ftraverse_ 45 | , ffor_ 46 | -- * Traversable 47 | , FTraversable(..) 48 | , ViaFTraversable(..) 49 | , ffmapDefault 50 | , ffoldMapDefault 51 | , ffor 52 | , fsequence 53 | , FFunctorWithIndex(..) 54 | , ifmapDefault 55 | , FFoldableWithIndex(..) 56 | , iffoldMapDefault 57 | , FTraversableWithIndex(..) 58 | , FApply(..) 59 | , FApplicative(..) 60 | , ViaFApplicative(..) 61 | -- * FBind 62 | , Coatkey(..) 63 | , runCoatkey 64 | , FBind(..) 65 | , ViaFBind(..) 66 | , FMonad 67 | , ViaFMonad(..) 68 | , fbindInner 69 | , fbindOuter 70 | -- * FEq 71 | , EqC, FEq 72 | -- * FOrd 73 | , OrdC', OrdC, FOrd 74 | -- * Higher kinded data 75 | -- | See also "Data.Some" in @some@ package. This package provides instances for it. 76 | , F0(..) 77 | , F1(..) 78 | , F2(F2,..) 79 | , F3(F3,..) 80 | , F4(F4,..) 81 | , F5(F5,..) 82 | , FConstrained(..) 83 | , FCompose(FCompose,runFCompose,..) 84 | , NT(..) 85 | , Lim(..), traverseLim 86 | , Dict1(..) 87 | , Dicts(Dicts,runDicts,..) 88 | , Atkey(..) 89 | , HKD(..), mapHKD 90 | , LKD(..) 91 | ) where 92 | 93 | import Control.Applicative 94 | import Data.Coerce 95 | import Data.Data 96 | import Data.Functor.Compose (Compose (..)) 97 | import Data.Functor.Contravariant 98 | import Data.Functor.Contravariant.Divisible 99 | import Data.Function.Coerce 100 | import Data.HKD.Classes 101 | import Data.HKD.Contravariant 102 | import Data.HKD.Index.Internal 103 | import Data.Functor.WithIndex 104 | import Data.Foldable.WithIndex 105 | import Data.Traversable.WithIndex 106 | import Data.Kind 107 | import Data.Some.Newtype (Some(..)) 108 | import Data.Void 109 | import GHC.Arr 110 | import GHC.Generics 111 | import Unsafe.Coerce 112 | 113 | type role F0 phantom 114 | data F0 f = F0 115 | deriving stock 116 | ( Generic, Generic1, Functor, Foldable, Traversable 117 | , Eq, Ord, Show, Read, Ix, Enum, Bounded, Data) 118 | deriving anyclass 119 | ( FFunctor, FFoldable, FTraversable 120 | , FFunctorWithIndex (Index '[]), FFoldableWithIndex (Index '[]) 121 | , FContravariant 122 | , FApplicative, FApply ) 123 | 124 | instance FTraversableWithIndex (Index '[]) F0 where 125 | iftraverse _ F0 = pure F0 126 | {-# inline iftraverse #-} 127 | 128 | -- * F1 129 | 130 | type role F1 nominal representational 131 | newtype F1 a f = F1 { runF1 :: f a } 132 | deriving stock (Eq, Ord, Show, Read, Data) 133 | deriving anyclass 134 | ( FFunctor 135 | , FFunctorWithIndex (Index '[a]) 136 | , FFoldableWithIndex (Index '[a]) 137 | ) 138 | 139 | instance FTraversableWithIndex (Index '[a]) (F1 a) where 140 | iftraverse f (F1 a) = F1 <$> f (UnsafeIndex 0) a 141 | {-# inline iftraverse #-} 142 | 143 | deriving newtype instance Ix (f a) => Ix (F1 a f) 144 | deriving newtype instance Enum (f a) => Enum (F1 a f) 145 | deriving newtype instance Bounded (f a) => Bounded (F1 a f) 146 | 147 | instance FFoldable (F1 a) where 148 | flengthAcc acc _ = acc + 1 149 | {-# inline flengthAcc #-} 150 | 151 | instance FTraversable (F1 a) where 152 | ftraverse f = fmap F1 . f .# runF1 153 | {-# inline ftraverse #-} 154 | 155 | instance FApplicative (F1 a) where 156 | fpure = \ x -> F1 x 157 | {-# inline fpure #-} 158 | 159 | instance FApply (F1 a) where 160 | fliftA2 = \ f (F1 a) (F1 b) -> F1 (f a b) 161 | {-# inline fliftA2 #-} 162 | 163 | instance FBind (F1 a) where 164 | fbind = \(F1 a) f -> F1 $ runCoatkey $ runF1 $ f a 165 | {-# inline fbind #-} 166 | 167 | type role F2 nominal nominal representational 168 | data F2 a b f = F2' (F1 a f) (F1 b f) 169 | deriving stock (Eq, Ord, Show, Read, Generic, Generic1, Data) 170 | deriving anyclass 171 | ( FFunctor, FFoldable, FTraversable, FApply, FApplicative 172 | , FFunctorWithIndex (Index '[a,b]) 173 | , FFoldableWithIndex (Index '[a,b]) 174 | ) 175 | 176 | pattern F2 :: f a -> f b -> F2 a b f 177 | pattern F2 a b = F2' (F1 a) (F1 b) 178 | {-# complete F2 :: F2 #-} 179 | 180 | instance FTraversableWithIndex (Index '[a,b]) (F2 a b) where 181 | iftraverse f (F2 a b) = liftA2 F2 182 | (f (UnsafeIndex 0) a) 183 | (f (UnsafeIndex 1) b) 184 | {-# inline iftraverse #-} 185 | 186 | instance FBind (F2 a b) where 187 | fbind = \(F2 a b) f -> 188 | F2 189 | (runCoatkey $ case f a of F2 x _ -> x) 190 | (runCoatkey $ case f b of F2 _ y -> y) 191 | {-# inline fbind #-} 192 | 193 | type role F3 nominal nominal nominal representational 194 | data F3 a b c f = F3' (F1 a f) (F1 b f) (F1 c f) 195 | deriving stock (Eq, Ord, Show, Read, Generic, Generic1, Data) 196 | deriving anyclass 197 | ( FFunctor, FFoldable, FTraversable, FApply, FApplicative 198 | , FFunctorWithIndex (Index '[a,b,c]) 199 | , FFoldableWithIndex (Index '[a,b,c]) 200 | ) 201 | 202 | pattern F3 :: f a -> f b -> f c -> F3 a b c f 203 | pattern F3 a b c = F3' (F1 a) (F1 b) (F1 c) 204 | {-# complete F3 :: F3 #-} 205 | 206 | instance FTraversableWithIndex (Index '[a,b,c]) (F3 a b c) where 207 | iftraverse f (F3 a b c) = liftA3 F3 208 | (f (UnsafeIndex 0) a) 209 | (f (UnsafeIndex 1) b) 210 | (f (UnsafeIndex 2) c) 211 | {-# inline iftraverse #-} 212 | 213 | instance FBind (F3 a b c) where 214 | fbind = \(F3 a b c) f -> 215 | F3 216 | (runCoatkey $ case f a of F3 x _ _ -> x) 217 | (runCoatkey $ case f b of F3 _ y _ -> y) 218 | (runCoatkey $ case f c of F3 _ _ z -> z) 219 | {-# inline fbind #-} 220 | 221 | type role F4 nominal nominal nominal nominal representational 222 | data F4 a b c d f = F4' (F1 a f) (F1 b f) (F1 c f) (F1 d f) 223 | deriving stock (Eq, Ord, Show, Read, Generic, Generic1, Data) 224 | deriving anyclass 225 | ( FFunctor, FFoldable, FTraversable, FApply, FApplicative 226 | , FFunctorWithIndex (Index '[a,b,c,d]) 227 | , FFoldableWithIndex (Index '[a,b,c,d]) 228 | ) 229 | 230 | pattern F4 :: f a -> f b -> f c -> f d -> F4 a b c d f 231 | pattern F4 a b c d = F4' (F1 a) (F1 b) (F1 c) (F1 d) 232 | {-# complete F4 :: F4 #-} 233 | 234 | instance FTraversableWithIndex (Index '[a,b,c,d]) (F4 a b c d) where 235 | iftraverse f (F4 a b c d) = liftA2 F4 236 | (f (UnsafeIndex 0) a) 237 | (f (UnsafeIndex 1) b) 238 | <*> f (UnsafeIndex 2) c 239 | <*> f (UnsafeIndex 3) d 240 | {-# inline iftraverse #-} 241 | 242 | instance FBind (F4 a b c d) where 243 | fbind = \(F4 a b c d) f -> 244 | F4 245 | (runCoatkey $ case f a of F4 x _ _ _ -> x) 246 | (runCoatkey $ case f b of F4 _ x _ _ -> x) 247 | (runCoatkey $ case f c of F4 _ _ x _ -> x) 248 | (runCoatkey $ case f d of F4 _ _ _ x -> x) 249 | {-# inline fbind #-} 250 | 251 | type role F5 nominal nominal nominal nominal nominal representational 252 | data F5 a b c d e f = F5' (F1 a f) (F1 b f) (F1 c f) (F1 d f) (F1 e f) 253 | deriving stock (Eq, Ord, Show, Read, Generic, Generic1, Data) 254 | deriving anyclass 255 | ( FFunctor, FFoldable, FTraversable, FApply, FApplicative 256 | , FFunctorWithIndex (Index '[a,b,c,d,e]) 257 | , FFoldableWithIndex (Index '[a,b,c,d,e]) 258 | ) 259 | 260 | pattern F5 :: f a -> f b -> f c -> f d -> f e -> F5 a b c d e f 261 | pattern F5 a b c d e = F5' (F1 a) (F1 b) (F1 c) (F1 d) (F1 e) 262 | {-# complete F5 :: F5 #-} 263 | 264 | instance FTraversableWithIndex (Index '[a,b,c,d,e]) (F5 a b c d e) where 265 | iftraverse f (F5 a b c d e) = liftA2 F5 266 | (f (UnsafeIndex 0) a) 267 | (f (UnsafeIndex 1) b) 268 | <*> f (UnsafeIndex 2) c 269 | <*> f (UnsafeIndex 3) d 270 | <*> f (UnsafeIndex 4) e 271 | {-# inline iftraverse #-} 272 | 273 | instance FBind (F5 a b c d e) where 274 | fbind = \(F5 a b c d e) f -> 275 | F5 276 | (runCoatkey $ case f a of F5 x _ _ _ _ -> x) 277 | (runCoatkey $ case f b of F5 _ x _ _ _ -> x) 278 | (runCoatkey $ case f c of F5 _ _ x _ _ -> x) 279 | (runCoatkey $ case f d of F5 _ _ _ x _ -> x) 280 | (runCoatkey $ case f e of F5 _ _ _ _ x -> x) 281 | {-# inline fbind #-} 282 | 283 | ------------------------------------------------------------------------------- 284 | -- "natural" transformations via parametricity 285 | ------------------------------------------------------------------------------- 286 | 287 | -- | Newtyped "natural" transformation 288 | newtype NT f g = NT { runNT :: f ~> g } 289 | 290 | 291 | instance FFunctor (NT f) where 292 | ffmap = \f (NT g) -> NT (f . g) 293 | {-# inline ffmap #-} 294 | 295 | instance FApply (NT f) where 296 | fliftA2 = \f (NT g) (NT h) -> NT \x -> f (g x) (h x) 297 | {-# inline fliftA2 #-} 298 | 299 | instance FApplicative (NT a) where 300 | fpure = \x -> NT \_ -> x 301 | {-# inline fpure #-} 302 | 303 | instance FBind (NT r) where 304 | fbind = \(NT ra) f -> NT \r -> runCoatkey $ runNT (f $ ra r) r 305 | {-# inline fbind #-} 306 | 307 | instance FFunctorWithIndex f (NT f) where 308 | ifmap f (NT g) = NT $ \r -> f r (g r) 309 | {-# inline ifmap #-} 310 | 311 | ------------------------------------------------------------------------------- 312 | -- Lim 313 | ------------------------------------------------------------------------------- 314 | 315 | newtype Lim f = Lim 316 | { runLim :: forall a. f a 317 | } 318 | 319 | unsafeLim :: f a -> Lim f 320 | unsafeLim = unsafeCoerce 321 | {-# inline unsafeLim #-} 322 | 323 | traverseLim :: forall f g. Traversable f => Lim (Compose f g) -> f (Lim g) 324 | traverseLim (Lim (Compose xs)) = fmap unsafeLim xs 325 | {-# inline traverseLim #-} 326 | 327 | deriving stock instance (forall a. Eq (f a)) => Eq (Lim f) 328 | deriving stock instance (forall a. Ord (f a)) => Ord (Lim f) 329 | deriving stock instance (forall a. Show (f a)) => Show (Lim f) 330 | deriving stock instance (forall a. Bounded (f a)) => Bounded (Lim f) 331 | 332 | instance (forall a. Enum (f a)) => Enum (Lim f) where 333 | toEnum x = Lim (toEnum x) 334 | {-# inline toEnum #-} 335 | fromEnum (Lim x) = fromEnum x 336 | {-# inline fromEnum #-} 337 | succ x = Lim (succ $ runLim x) 338 | {-# inline succ #-} 339 | pred x = Lim (pred $ runLim x) 340 | {-# inline pred #-} 341 | enumFrom (Lim x) = unsafeLim <$> enumFrom x 342 | {-# inline enumFrom #-} 343 | enumFromTo (Lim x) (Lim y) = unsafeLim <$> enumFromTo x y 344 | {-# inline enumFromTo #-} 345 | enumFromThen (Lim x) (Lim y) = unsafeLim <$> enumFromThen x y 346 | {-# inline enumFromThen #-} 347 | enumFromThenTo (Lim x) (Lim y) (Lim z) = unsafeLim <$> enumFromThenTo x y z 348 | {-# inline enumFromThenTo #-} 349 | 350 | instance (forall a. Ix (f a)) => Ix (Lim f) where 351 | -- this can be implemented in quadratic time without unsafeCoerce 352 | range (Lim a, Lim b) = unsafeLim <$> range (a, b) 353 | {-# inline range #-} 354 | index (Lim a, Lim b) (Lim c) = index (a, b) c 355 | {-# inline index #-} 356 | unsafeIndex (Lim a, Lim b) (Lim c) = unsafeIndex (a, b) c 357 | {-# inline unsafeIndex #-} 358 | inRange (Lim a, Lim b) (Lim c) = inRange (a, b) c 359 | {-# inline inRange #-} 360 | rangeSize (Lim a, Lim b) = rangeSize (a, b) 361 | {-# inline rangeSize #-} 362 | unsafeRangeSize (Lim a, Lim b) = unsafeRangeSize (a, b) 363 | {-# inline unsafeRangeSize #-} 364 | 365 | instance FFunctor Lim where 366 | ffmap f (Lim g) = Lim (f g) 367 | {-# inline ffmap #-} 368 | 369 | instance FFoldable Lim where 370 | ffoldMap f (Lim g) = f g 371 | flengthAcc l _ = l + 1 372 | {-# inline ffoldMap #-} 373 | {-# inline flengthAcc #-} 374 | 375 | instance FTraversable Lim where 376 | ftraverse = \ f (Lim m) -> unsafeLim <$> f m 377 | {-# inline ftraverse #-} 378 | 379 | instance FApply Lim where 380 | fliftA2 f (Lim x) (Lim y) = Lim (f x y) 381 | {-# inline fliftA2 #-} 382 | 383 | instance FApplicative Lim where 384 | fpure x = Lim x 385 | {-# inline fpure #-} 386 | 387 | instance FBind Lim where 388 | fbind = \(Lim a) f -> Lim $ runCoatkey $ runLim $ f a 389 | {-# inline fbind #-} 390 | 391 | -- * Dicts 392 | 393 | data Dict1 p a where 394 | Dict1 :: p a => Dict1 p a 395 | 396 | deriving stock instance (Typeable k, Typeable a, Typeable p, p a) => Data (Dict1 p (a :: k)) 397 | deriving stock instance Eq (Dict1 p a) 398 | deriving stock instance Ord (Dict1 p a) 399 | deriving stock instance Show (Dict1 p a) 400 | deriving stock instance p a => Read (Dict1 p a) 401 | 402 | instance p a => Enum (Dict1 p a) where 403 | succ = error "Dict1.succ" 404 | pred = error "Dict1.pred" 405 | toEnum 0 = Dict1 406 | toEnum _ = error "Dict1.toEnum" 407 | fromEnum Dict1 = 0 408 | enumFrom Dict1 = [Dict1] 409 | enumFromTo Dict1 Dict1 = [Dict1] 410 | enumFromThen Dict1 Dict1 = repeat Dict1 411 | enumFromThenTo Dict1 Dict1 Dict1 = repeat Dict1 412 | 413 | deriving stock instance p a => Bounded (Dict1 p a) 414 | deriving stock instance Ix (Dict1 p a) 415 | 416 | newtype Dicts p f = Dicts' 417 | { runDicts' :: F1 (Dict1 p) f 418 | } 419 | deriving stock (Generic, Generic1) 420 | deriving anyclass (FFunctor, FFoldable, FTraversable, FApply, FApplicative) 421 | 422 | pattern Dicts :: f (Dict1 p) -> Dicts p f 423 | pattern Dicts { runDicts } = Dicts' (F1 runDicts) 424 | 425 | {-# complete Dicts #-} 426 | 427 | deriving newtype instance Eq (f (Dict1 p)) => Eq (Dicts p f) 428 | deriving newtype instance Ord (f (Dict1 p)) => Ord (Dicts p f) 429 | 430 | instance FBind (Dicts p) where 431 | fbind = \(Dicts a) f -> Dicts $ runCoatkey $ runDicts (f a) 432 | {-# inline fbind #-} 433 | 434 | -- * FConstrained 435 | 436 | newtype FConstrained p f = FConstrained 437 | { runFConstrained :: forall x. p x => f x 438 | } 439 | 440 | {- 441 | instance 442 | ( Typeable k 443 | , Typeable p 444 | , Typeable f 445 | , forall x. p x => Data (f x) 446 | ) => Data (FConstrained (p :: k -> Constraint) f) where 447 | 448 | toConstr _ = conFConstrained 449 | dataTypeOf _ = tyFConstrained 450 | gunfold k z c = case constrIndex c of 451 | 1 -> k (z FConstrained) -- need some way to sneak into c here 452 | 453 | tyFConstrained :: DataType 454 | tyFConstrained = mkDataType "Data.HKD.FConstrained" [conFConstrained] 455 | {-# noinline tyFConstrained #-} 456 | 457 | conFConstrained :: Constr 458 | conFConstrained = mkConstr tyFConstrained "C1" [] Data.Data.Prefix 459 | {-# noinline conFConstrained #-} 460 | -} 461 | 462 | instance FFunctor (FConstrained p) where 463 | ffmap = \f x -> FConstrained (f $ runFConstrained x) 464 | {-# inline ffmap #-} 465 | 466 | instance (forall x. p x) => FFoldable (FConstrained p) where 467 | ffoldMap = \ f x -> f $ runFConstrained x 468 | {-# inline ffoldMap #-} 469 | 470 | instance FApply (FConstrained p) where 471 | fliftA2 = \f g h -> FConstrained $ f (runFConstrained g) (runFConstrained h) 472 | {-# inline fliftA2 #-} 473 | 474 | instance FApplicative (FConstrained p) where 475 | fpure x = FConstrained x 476 | {-# inline fpure #-} 477 | 478 | instance FBind (FConstrained p) where 479 | fbind = \(FConstrained a) f -> FConstrained $ runCoatkey $ runFConstrained $ f a 480 | {-# inline fbind #-} 481 | 482 | -- instance (forall x. p x) => FTraversable (FConstrained p) where 483 | 484 | type role FCompose nominal representational nominal 485 | newtype FCompose a f g = FCompose' { runFCompose' :: f (F1 a g) } 486 | deriving stock (Generic, Generic1) 487 | 488 | deriving stock instance Eq (f (F1 a g)) => Eq (FCompose a f g) 489 | deriving stock instance Ord (f (F1 a g)) => Ord (FCompose a f g) 490 | deriving stock instance Show (f (F1 a g)) => Show (FCompose a f g) 491 | deriving stock instance Read (f (F1 a g)) => Read (FCompose a f g) 492 | 493 | pattern FCompose :: Functor f => f (g a) -> FCompose a f g 494 | pattern FCompose { runFCompose } <- FCompose' (fmap runF1 -> runFCompose) where 495 | FCompose f = FCompose' (fmap F1 f) 496 | {-# COMPLETE FCompose #-} 497 | 498 | deriving stock instance 499 | ( Typeable k 500 | , Typeable a 501 | , Typeable f 502 | , Typeable g 503 | , Data (f (F1 a g)) 504 | ) => Data (FCompose (a :: k) f g) 505 | 506 | instance Functor f => FFunctor (FCompose a f) where 507 | ffmap = \f -> FCompose' #. (fmap (F1 #. f .# runF1) .# runFCompose') 508 | {-# inline ffmap #-} 509 | 510 | instance Foldable f => FFoldable (FCompose a f) where 511 | ffoldMap = \f -> foldMap (f .# runF1) .# runFCompose' 512 | {-# inline ffoldMap #-} 513 | 514 | instance Traversable f => FTraversable (FCompose a f) where 515 | ftraverse = \f -> fmap FCompose' . traverse (fmap F1 . f .# runF1) .# runFCompose' 516 | {-# inline ftraverse #-} 517 | 518 | type role HKD representational nominal nominal 519 | newtype HKD (f :: Type -> Type) (x :: i) (a :: i -> Type) = HKD { runHKD :: f (F1 x a) } 520 | 521 | mapHKD :: (f (F1 x a) -> g (F1 x b)) -> HKD f x a -> HKD g x b 522 | mapHKD = \f -> HKD #. f .# runHKD 523 | {-# inline mapHKD #-} 524 | 525 | type role Atkey representational nominal nominal 526 | data Atkey a i j where 527 | Atkey :: a -> Atkey a k k 528 | 529 | -- if HKD took x as its first parameter i could use FCompose 530 | type role DHKD representational nominal nominal 531 | newtype DHKD w x f = DHKD { runDHKD :: w (HKD f x) } 532 | instance FFunctor w => FFunctor (DHKD w x) where 533 | ffmap f = DHKD #. ffmap (mapHKD f) .# runDHKD 534 | {-# inline ffmap #-} 535 | 536 | instance Functor f => FFunctor (HKD f x) where 537 | ffmap = \f -> mapHKD (fmap (F1 #. f .# runF1)) 538 | {-# inline ffmap #-} 539 | 540 | instance FunctorWithIndex i f => FFunctorWithIndex (Atkey i x) (HKD f x) where 541 | ifmap = \f -> mapHKD (imap (\i -> F1 #. f (Atkey i) .# runF1)) 542 | {-# inline ifmap #-} 543 | 544 | instance Foldable f => FFoldable (HKD f x) where 545 | ffoldMap = \f -> foldMap (f .# runF1) .# runHKD 546 | {-# inline ffoldMap #-} 547 | 548 | instance FoldableWithIndex i f => FFoldableWithIndex (Atkey i x) (HKD f x) where 549 | iffoldMap = \f -> ifoldMap (\i -> f (Atkey i) .# runF1) .# runHKD 550 | {-# inline iffoldMap #-} 551 | 552 | instance Traversable f => FTraversable (HKD f x) where 553 | ftraverse = \f -> fmap HKD . traverse (fmap F1 . f .# runF1) .# runHKD 554 | {-# inline ftraverse #-} 555 | 556 | instance TraversableWithIndex i f => FTraversableWithIndex (Atkey i x) (HKD f x) where 557 | iftraverse = \f -> fmap HKD . itraverse (\i -> fmap F1 . f (Atkey i) .# runF1) .# runHKD 558 | {-# inline iftraverse #-} 559 | 560 | instance Applicative f => FApply (HKD f x) where 561 | fliftA2 = \f (HKD fab) -> HKD #. liftA2 (\(F1 i) (F1 j) -> F1 $ f i j) fab .# runHKD 562 | {-# inline fliftA2 #-} 563 | 564 | instance Applicative f => FApplicative (HKD f x) where 565 | fpure f = HKD $ pure (F1 f) 566 | {-# inline fpure #-} 567 | 568 | instance Monad f => FBind (HKD f x) where 569 | fbind = \(HKD fa) f -> HKD $ fmap (F1 #. runCoatkey .# runF1) $ fa >>= runHKD #. f .# runF1 570 | {-# inline fbind #-} 571 | 572 | instance Contravariant f => FContravariant (HKD f x) where 573 | fcontramap = \f -> HKD #. contramap (F1 #. f .# runF1) .# runHKD 574 | {-# inline fcontramap #-} 575 | 576 | instance Divisible f => FSemidivisible (HKD f x) where 577 | fdivide = \f g -> HKD #. divide (\(F1 a) -> case f a of (b :*: c) -> (F1 b, F1 c)) (runHKD g) .# runHKD 578 | {-# inline fdivide #-} 579 | 580 | instance Divisible f => FDivisible (HKD f x) where 581 | fconquer = HKD conquer 582 | {-# inline fconquer #-} 583 | 584 | instance Decidable f => FSemidecidable (HKD f x) where 585 | fchoose = \f g -> HKD #. choose (\(F1 a) -> case f a of 586 | L1 x -> Left (F1 x) 587 | R1 y -> Right (F1 y)) (runHKD g) .# runHKD 588 | {-# inline fchoose #-} 589 | flose f = HKD (lose \(F1 x) -> case f x of) 590 | {-# inline flose #-} 591 | 592 | -- LKD 593 | 594 | type role LKD representational nominal 595 | newtype LKD f a = LKD { runLKD :: f (Const a) } 596 | 597 | deriving stock instance 598 | ( Typeable f 599 | , Typeable a 600 | , Typeable k 601 | , Data (f (Const a)) 602 | ) => Data (LKD (f :: (k -> Type) -> Type) a) 603 | 604 | instance FFunctor f => Functor (LKD f) where 605 | fmap = \f -> LKD #. ffmap (Const #. f .# getConst) .# runLKD 606 | {-# inline fmap #-} 607 | 608 | instance FFunctorWithIndex i f => FunctorWithIndex (Some i) (LKD f) where 609 | imap = \f -> LKD #. ifmap (\i -> Const #. f (Some i) .# getConst) .# runLKD 610 | 611 | instance FFoldable f => Foldable (LKD f) where 612 | foldMap = \f -> ffoldMap (f .# getConst) .# runLKD 613 | {-# inline foldMap #-} 614 | 615 | instance FFoldableWithIndex i f => FoldableWithIndex (Some i) (LKD f) where 616 | ifoldMap = \f -> iffoldMap (\i -> f (Some i) .# getConst) .# runLKD 617 | {-# inline ifoldMap #-} 618 | 619 | instance FTraversable f => Traversable (LKD f) where 620 | traverse = \f -> fmap LKD . ftraverse (fmap Const . f .# getConst) .# runLKD 621 | {-# inline traverse #-} 622 | 623 | instance FTraversableWithIndex i f => TraversableWithIndex (Some i) (LKD f) where 624 | itraverse = \f -> fmap LKD . iftraverse (\i -> fmap Const . f (Some i) .# getConst) .# runLKD 625 | {-# inline itraverse #-} 626 | 627 | instance FContravariant f => Contravariant (LKD f) where 628 | contramap = \f -> LKD #. fcontramap (Const #. f .# getConst) .# runLKD 629 | {-# inline contramap #-} 630 | 631 | instance FDivisible f => Divisible (LKD f) where 632 | divide = \f g -> LKD #. fdivide 633 | (\(Const a) -> case f a of 634 | (b,c) -> Const b :*: Const c 635 | ) 636 | (runLKD g) .# runLKD 637 | {-# inline divide #-} 638 | conquer = LKD fconquer 639 | {-# inline conquer #-} 640 | 641 | instance FDecidable f => Decidable (LKD f) where 642 | choose = \f g -> LKD #. fchoose 643 | (\(Const a) -> case f a of 644 | Left b -> L1 (Const b) 645 | Right b -> R1 (Const b)) (runLKD g) .# runLKD 646 | {-# inline choose #-} 647 | 648 | lose = \f -> LKD $ flose (absurd . f .# getConst) 649 | {-# inline lose #-} 650 | 651 | instance FApplicative f => Applicative (LKD f) where 652 | (<*>) = \(LKD fab) -> LKD #. fliftA2 coerce fab .# runLKD 653 | {-# inline (<*>) #-} 654 | pure = \a -> LKD $ fpure (Const a) 655 | {-# inline pure #-} 656 | 657 | 658 | 659 | instance FMonad f => Monad (LKD f) where 660 | (>>=) = \(LKD fa) f -> LKD $ fbindOuter fa \(Const a) -> ffmap coerce $ runLKD $ f a 661 | {-#inline (>>=) #-} 662 | 663 | -------------------------------------------------------------------------------- /src/Data/HKD/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language GeneralizedNewtypeDeriving #-} 3 | {-# Language Trustworthy #-} 4 | 5 | -- | 6 | -- Copyright : (c) 2019-2021 Edward Kmett 7 | -- (c) 2019 Oleg Grenrus 8 | -- (c) 2017-2021 Aaron Vargo 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer: Edward Kmett 11 | -- Stability : experimental 12 | -- Portability: non-portable 13 | -- 14 | -- "Higher-Kinded Data" such as it is 15 | -- 16 | -- Simple usage: 17 | -- 18 | -- @ 19 | -- data Record f = Record 20 | -- { fieldInt :: f Int 21 | -- , fieldString :: f String 22 | -- , fieldSome :: 'Some' f 23 | -- } deriving ('Generic1', 'FFunctor', 'FFoldable', 'FTraversable') 24 | -- @ 25 | -- 26 | -- Generically derived 'FApply' and 'FApplicative': 27 | -- 28 | -- @ 29 | -- data Record f = Record 30 | -- { fieldInt :: f Int 31 | -- , fieldString :: f String 32 | -- } deriving ('Generic1', 'FApply', 'FApplicative') 33 | -- @ 34 | module Data.HKD.Classes 35 | ( 36 | -- * "Natural" transformation 37 | type (~>) 38 | -- * Functor 39 | , FFunctor(..) 40 | , gffmap 41 | -- * Foldable 42 | , FFoldable(..) 43 | , gffoldMap 44 | , ftoList 45 | , flength 46 | , ftraverse_ 47 | , ffor_ 48 | -- * Traversable 49 | , FTraversable(..) 50 | , ViaFTraversable(..) 51 | , ffmapDefault 52 | , ffoldMapDefault 53 | , ffor 54 | , fsequence 55 | , FFunctorWithIndex(..) 56 | , ifmapDefault 57 | , FFoldableWithIndex(..) 58 | , iffoldMapDefault 59 | , iftoList 60 | , FTraversableWithIndex(..) 61 | , FApply(..) 62 | , FApplicative(..) 63 | , ViaFApplicative(..) 64 | -- * FBind 65 | , Coatkey(..) 66 | , runCoatkey 67 | , FBind(..) 68 | , ViaFBind(..) 69 | , FMonad 70 | , ViaFMonad(..) 71 | , fbindInner 72 | , fbindOuter 73 | -- * FEq 74 | , EqC, FEq 75 | -- * FOrd 76 | , OrdC', OrdC, FOrd 77 | ) where 78 | 79 | import Control.Applicative 80 | import Control.Applicative.Backwards 81 | import Control.Monad(join) 82 | import Data.Coerce 83 | import qualified Data.Dependent.HashMap as DHashMap 84 | import Data.Dependent.HashMap (DHashMap) 85 | import Data.Dependent.Sum 86 | import Data.Foldable.WithIndex 87 | import Data.Function.Coerce 88 | import Data.Functor.Constant 89 | import Data.Functor.Compose (Compose (..)) 90 | import Data.Functor.Identity (Identity (..)) 91 | import Data.Functor.Product (Product (..)) 92 | import Data.Functor.Reverse 93 | import Data.Functor.Sum (Sum (..)) 94 | import Data.Functor.WithIndex 95 | import Data.GADT.Compare 96 | import Data.Hashable 97 | import Data.HKD.Orphans () 98 | import Data.Kind (Type, Constraint) 99 | import qualified Data.Monoid as Monoid 100 | import Data.Proxy (Proxy (..)) 101 | import qualified Data.Some.GADT as G 102 | import Data.Some.Newtype (Some (..), mapSome, foldSome, withSome, traverseSome) 103 | import qualified Data.Some.Church as C 104 | import Data.Traversable.Confusing 105 | import Data.Traversable.WithIndex 106 | import GHC.Generics 107 | 108 | ------------------------------------------------------------------------------- 109 | -- wiggly arrow 110 | ------------------------------------------------------------------------------- 111 | 112 | type f ~> g = forall a. f a -> g a 113 | infixr 0 ~> 114 | 115 | ------------------------------------------------------------------------------- 116 | -- FFunctor 117 | ------------------------------------------------------------------------------- 118 | 119 | class FFunctor (t :: (k -> Type) -> Type) where 120 | ffmap :: (f ~> g) -> t f -> t g 121 | default ffmap :: FTraversable t => (f ~> g) -> t f -> t g 122 | ffmap = ffmapDefault 123 | {-# inline ffmap #-} 124 | 125 | gffmap :: (Generic1 t, FFunctor (Rep1 t)) => (f ~> g) -> t f -> t g 126 | gffmap f = to1 . ffmap f . from1 127 | {-# inline gffmap #-} 128 | 129 | instance FFunctor (DHashMap f) where 130 | ffmap = DHashMap.map 131 | {-# inline ffmap #-} 132 | 133 | instance FFunctor (DSum f) where 134 | ffmap f (g :=> h) = g :=> f h 135 | {-# inline ffmap #-} 136 | 137 | instance FFunctor Proxy where 138 | ffmap = \_ -> coerce 139 | {-# inline ffmap #-} 140 | 141 | instance FFunctor (Const a) where 142 | ffmap = \_ -> coerce 143 | {-# inline ffmap #-} 144 | 145 | instance FFunctor (Constant a) where 146 | ffmap = \_ -> coerce 147 | {-# inline ffmap #-} 148 | 149 | instance (Functor f, FFunctor g) => FFunctor (Compose f g) where 150 | ffmap f = Compose #. fmap (ffmap f) .# getCompose 151 | {-# inline ffmap #-} 152 | 153 | instance (FFunctor f, FFunctor g) => FFunctor (Product f g) where 154 | ffmap f (Pair g h) = Pair (ffmap f g) (ffmap f h) 155 | {-# inline ffmap #-} 156 | 157 | instance (FFunctor f, FFunctor g) => FFunctor (Sum f g) where 158 | ffmap f (InL g) = InL (ffmap f g) 159 | ffmap f (InR h) = InR (ffmap f h) 160 | {-# inline ffmap #-} 161 | 162 | instance FFunctor (K1 i a) where 163 | ffmap _ = coerce 164 | {-# inline ffmap #-} 165 | 166 | deriving newtype instance FFunctor f => FFunctor (M1 i c f) 167 | deriving newtype instance FFunctor f => FFunctor (Rec1 f) 168 | 169 | instance FFunctor U1 170 | instance FFunctor V1 171 | 172 | instance (Functor f, FFunctor g) => FFunctor (f :.: g) where 173 | ffmap f = Comp1 #. fmap (ffmap f) .# unComp1 174 | {-# inline ffmap #-} 175 | 176 | instance (FFunctor f, FFunctor g) => FFunctor (f :*: g) where 177 | ffmap f (g :*: h) = ffmap f g :*: ffmap f h 178 | {-# inline ffmap #-} 179 | 180 | instance (FFunctor f, FFunctor g) => FFunctor (f :+: g) where 181 | ffmap f (L1 g) = L1 (ffmap f g) 182 | ffmap f (R1 h) = R1 (ffmap f h) 183 | {-# inline ffmap #-} 184 | 185 | ------------------------------------------------------------------------------- 186 | -- FFoldable 187 | ------------------------------------------------------------------------------- 188 | 189 | class FFoldable (t :: (k -> Type) -> Type) where 190 | ffoldMap :: Monoid m => (forall a. f a -> m) -> t f -> m 191 | default ffoldMap :: (FTraversable t, Monoid m) => (forall a. f a -> m) -> t f -> m 192 | ffoldMap = ffoldMapDefault 193 | {-# inline ffoldMap #-} 194 | 195 | flengthAcc :: Int -> t f -> Int 196 | flengthAcc acc t = acc + Monoid.getSum (ffoldMap (\_ -> Monoid.Sum 1) t) 197 | {-# inline flengthAcc #-} 198 | 199 | ftoList :: FFoldable t => t f -> [Some f] 200 | ftoList = ffoldMap (\x -> [Some x]) 201 | {-# inline ftoList #-} 202 | 203 | gffoldMap :: (Generic1 t, FFoldable (Rep1 t), Monoid m) => (forall a. f a -> m) -> t f -> m 204 | gffoldMap f = ffoldMap f . from1 205 | {-# inline gffoldMap #-} 206 | 207 | flength :: FFoldable t => t f -> Int 208 | flength = flengthAcc 0 209 | {-# inline flength #-} 210 | 211 | ftraverse_ :: (FFoldable t, Applicative m) => (forall a. f a -> m b) -> t f -> m () 212 | ftraverse_ k tf = withSome (ffoldMap (Some . k) tf) (() <$) 213 | {-# inline ftraverse_ #-} 214 | 215 | ffor_ :: (FFoldable t, Applicative m) => t f -> (forall a. f a -> m b) -> m () 216 | ffor_ tf k = ftraverse_ k tf 217 | {-# inline ffor_ #-} 218 | 219 | instance FFoldable (DSum f) where 220 | ffoldMap f (_ :=> h) = f h 221 | {-# inline ffoldMap #-} 222 | flengthAcc n _ = n + 1 223 | {-# inline flengthAcc #-} 224 | 225 | instance FFoldable (DHashMap f) where 226 | ffoldMap = DHashMap.foldMap 227 | {-# inline ffoldMap #-} 228 | flengthAcc n m = n + DHashMap.size m 229 | {-# inline flengthAcc #-} 230 | 231 | instance FFoldable Proxy where 232 | flengthAcc = const 233 | {-# inline flengthAcc #-} 234 | 235 | instance FFoldable (Const a) where 236 | flengthAcc = const 237 | {-# inline flengthAcc #-} 238 | 239 | instance FFoldable (Constant a) where 240 | flengthAcc = const 241 | {-# inline flengthAcc #-} 242 | 243 | instance (Foldable f, FFoldable g) => FFoldable (Compose f g) where 244 | ffoldMap f = foldMap (ffoldMap f) .# getCompose 245 | {-# inline ffoldMap #-} 246 | 247 | instance (FFoldable f, FFoldable g) => FFoldable (Product f g) where 248 | ffoldMap f (Pair g h) = ffoldMap f g `mappend` ffoldMap f h 249 | flengthAcc f (Pair g h) = f `flengthAcc` g `flengthAcc` h 250 | {-# inline ffoldMap #-} 251 | {-# inline flengthAcc #-} 252 | 253 | instance (FFoldable f, FFoldable g) => FFoldable (Sum f g) where 254 | ffoldMap f (InL g) = ffoldMap f g 255 | ffoldMap f (InR h) = ffoldMap f h 256 | flengthAcc f (InL g) = flengthAcc f g 257 | flengthAcc f (InR h) = flengthAcc f h 258 | {-# inline ffoldMap #-} 259 | {-# inline flengthAcc #-} 260 | 261 | instance FFoldable V1 where 262 | flengthAcc _ = \case 263 | {-# inline flengthAcc #-} 264 | 265 | instance FFoldable (K1 i a) where 266 | flengthAcc = const 267 | {-# inline flengthAcc #-} 268 | 269 | deriving newtype instance FFoldable f => FFoldable (M1 i c f) 270 | deriving newtype instance FFoldable f => FFoldable (Rec1 f) 271 | 272 | instance FFoldable U1 where 273 | flengthAcc = const 274 | {-# inline flengthAcc #-} 275 | 276 | instance (Foldable f, FFoldable g) => FFoldable (f :.: g) where 277 | ffoldMap f = foldMap (ffoldMap f) .# unComp1 278 | {-# inline ffoldMap #-} 279 | 280 | instance (FFoldable f, FFoldable g) => FFoldable (f :*: g) where 281 | ffoldMap f (g :*: h) = ffoldMap f g `mappend` ffoldMap f h 282 | flengthAcc acc (g :*: h) = acc `flengthAcc` g `flengthAcc` h 283 | {-# inline ffoldMap #-} 284 | {-# inline flengthAcc #-} 285 | 286 | instance (FFoldable f, FFoldable g) => FFoldable (f :+: g) where 287 | ffoldMap f (L1 g) = ffoldMap f g 288 | ffoldMap f (R1 h) = ffoldMap f h 289 | flengthAcc acc (L1 g) = flengthAcc acc g 290 | flengthAcc acc (R1 g) = flengthAcc acc g 291 | {-# inline ffoldMap #-} 292 | {-# inline flengthAcc #-} 293 | 294 | ------------------------------------------------------------------------------- 295 | -- FTraversable 296 | ------------------------------------------------------------------------------- 297 | 298 | class (FFoldable t, FFunctor t) => FTraversable (t :: (k -> Type) -> Type) where 299 | ftraverse :: Applicative m => (forall a. f a -> m (g a)) -> t f -> m (t g) 300 | default ftraverse 301 | :: forall f g m. (Generic1 t, FTraversable (Rep1 t), Applicative m) 302 | => (forall a. f a -> m (g a)) -> t f -> m (t g) 303 | ftraverse = fconfusing (\nt -> fmap to1 . ftraverse nt . from1) 304 | {-# inline ftraverse #-} 305 | 306 | ffmapDefault :: FTraversable t => (f ~> g) -> t f -> t g 307 | ffmapDefault k = runIdentity #. ftraverse (Identity #. k) 308 | {-# inline ffmapDefault #-} 309 | 310 | ffoldMapDefault :: (FTraversable t, Monoid m) => (forall a. f a -> m) -> t f -> m 311 | ffoldMapDefault k = getConst #. ftraverse (Const #. k) 312 | {-# inline ffoldMapDefault #-} 313 | 314 | ffor :: (FTraversable t, Applicative m) => t f -> (forall a. f a -> m (g a)) -> m (t g) 315 | ffor tf k = ftraverse k tf 316 | {-# inline ffor #-} 317 | 318 | fsequence :: (FTraversable t, Applicative f) => t f -> f (t Identity) 319 | fsequence = ftraverse (fmap Identity) 320 | {-# inline fsequence #-} 321 | 322 | -- | For use with DerivingVia 323 | newtype ViaFTraversable t f = ViaFTraversable { runViaFTraversable :: t f } 324 | 325 | instance FTraversable t => FFunctor (ViaFTraversable t) where 326 | ffmap = \f -> ViaFTraversable #. ffmapDefault f .# runViaFTraversable 327 | {-# inline ffmap #-} 328 | 329 | instance FTraversable t => FFoldable (ViaFTraversable t) where 330 | ffoldMap = \f -> ffoldMapDefault f .# runViaFTraversable 331 | {-# inline ffoldMap #-} 332 | 333 | instance FTraversable (DSum f) where 334 | ftraverse f (g :=> h) = (g :=>) <$> f h 335 | {-# inline ftraverse #-} 336 | 337 | instance FTraversable (DHashMap f) where 338 | ftraverse = DHashMap.traverse 339 | {-# inline ftraverse #-} 340 | 341 | instance FTraversable Proxy where 342 | ftraverse _ Proxy = pure Proxy 343 | {-# inline ftraverse #-} 344 | 345 | instance FTraversable (Const a) where 346 | ftraverse _ = pure .# (Const . getConst) 347 | {-# inline ftraverse #-} 348 | 349 | instance FTraversable (Constant a) where 350 | ftraverse _ = pure .# (Constant . getConstant) 351 | {-# inline ftraverse #-} 352 | 353 | instance (Traversable f, FTraversable g) => FTraversable (Compose f g) where 354 | ftraverse f = fmap Compose . traverse (ftraverse f) .# getCompose 355 | {-# inline ftraverse #-} 356 | 357 | instance (FTraversable f, FTraversable g) => FTraversable (Product f g) where 358 | ftraverse f (Pair g h) = Pair <$> ftraverse f g <*> ftraverse f h 359 | {-# inline ftraverse #-} 360 | 361 | instance (FTraversable f, FTraversable g) => FTraversable (Sum f g) where 362 | ftraverse f (InL g) = InL <$> ftraverse f g 363 | ftraverse f (InR h) = InR <$> ftraverse f h 364 | {-# inline ftraverse #-} 365 | 366 | instance FTraversable U1 where 367 | ftraverse _ U1 = pure U1 368 | {-# inline ftraverse #-} 369 | 370 | instance FTraversable V1 where 371 | ftraverse _ = \case 372 | {-# inline ftraverse #-} 373 | 374 | instance FTraversable f => FTraversable (M1 i c f) where 375 | ftraverse f = fmap M1 . ftraverse f .# unM1 376 | {-# inline ftraverse #-} 377 | 378 | instance FTraversable f => FTraversable (Rec1 f) where 379 | ftraverse f = fmap Rec1 . ftraverse f .# unRec1 380 | {-# inline ftraverse #-} 381 | 382 | instance FTraversable (K1 i a) where 383 | ftraverse _ = pure .# (K1 . unK1) 384 | {-# inline ftraverse #-} 385 | 386 | instance (Traversable f, FTraversable g) => FTraversable (f :.: g) where 387 | ftraverse f = fmap Comp1 . traverse (ftraverse f) .# unComp1 388 | {-# inline ftraverse #-} 389 | 390 | instance (FTraversable f, FTraversable g) => FTraversable (f :*: g) where 391 | ftraverse f (g :*: h) = (:*:) <$> ftraverse f g <*> ftraverse f h 392 | {-# inline ftraverse #-} 393 | 394 | instance (FTraversable f, FTraversable g) => FTraversable (f :+: g) where 395 | ftraverse f (L1 g) = L1 <$> ftraverse f g 396 | ftraverse f (R1 h) = R1 <$> ftraverse f h 397 | {-# inline ftraverse #-} 398 | 399 | ------------------------------------------------------------------------------- 400 | -- FApply 401 | ------------------------------------------------------------------------------- 402 | 403 | class FFunctor t => FApply t where 404 | fliftA2 :: (forall x. f x -> g x -> h x) -> t f -> t g -> t h 405 | default fliftA2 :: (Generic1 t, FApply (Rep1 t)) => (forall x. f x -> g x -> h x) -> t f -> t g -> t h 406 | fliftA2 nt x y = to1 (fliftA2 nt (from1 x) (from1 y)) 407 | {-# inline fliftA2 #-} 408 | 409 | class FApply t => FApplicative t where 410 | fpure :: (forall x. f x) -> t f 411 | default fpure :: (Generic1 t, FApplicative (Rep1 t)) => (forall x. f x) -> t f 412 | fpure fx = to1 $ fpure fx 413 | {-# inline fpure #-} 414 | 415 | -- | For use with DerivingVia 416 | newtype ViaFApplicative t f = ViaFApplicative { runViaFApplicative :: t f } 417 | 418 | instance (GEq f, Hashable (Some f)) => FApply (DHashMap f) where 419 | fliftA2 = DHashMap.intersectionWith 420 | {-# inline fliftA2 #-} 421 | 422 | instance FApply t => FFunctor (ViaFApplicative t) where 423 | ffmap = \f -> ViaFApplicative #. join (fliftA2 (const f)) .# runViaFApplicative 424 | {-# inline ffmap #-} 425 | 426 | instance FApply Proxy where 427 | fliftA2 _ _ _ = Proxy 428 | {-# inline fliftA2 #-} 429 | 430 | instance FApplicative Proxy where 431 | fpure _ = Proxy 432 | {-# inline fpure #-} 433 | 434 | instance Semigroup a => FApply (Const a) where 435 | fliftA2 _ (Const a) (Const b) = Const (a <> b) 436 | {-# inline fliftA2 #-} 437 | 438 | instance Monoid a => FApplicative (Const a) where 439 | fpure _ = Const mempty 440 | {-# inline fpure #-} 441 | 442 | instance (FApply f, FApply g) => FApply (Product f g) where 443 | fliftA2 f (Pair x y) (Pair x' y') = Pair (fliftA2 f x x') (fliftA2 f y y') 444 | {-# inline fliftA2 #-} 445 | 446 | instance (FApplicative f, FApplicative g) => FApplicative (Product f g) where 447 | fpure x = Pair (fpure x) (fpure x) 448 | {-# inline fpure #-} 449 | 450 | -- | We only need an 'Apply' part of an 'Applicative'. 451 | instance (Applicative f, FApply g) => FApply (Compose f g) where 452 | fliftA2 f (Compose x) (Compose y) = Compose (liftA2 (fliftA2 f) x y) 453 | {-# inline fliftA2 #-} 454 | 455 | instance (Applicative f, FApplicative g) => FApplicative (Compose f g) where 456 | fpure x = Compose (pure (fpure x)) 457 | {-# inline fpure #-} 458 | 459 | instance FApply U1 where 460 | fliftA2 _ _ _ = U1 461 | {-# inline fliftA2 #-} 462 | 463 | instance FApplicative U1 where 464 | fpure _ = U1 465 | {-# inline fpure #-} 466 | 467 | instance FApply V1 where 468 | fliftA2 _ x _ = case x of 469 | {-# inline fliftA2 #-} 470 | 471 | instance FApply f => FApply (M1 i c f) where 472 | fliftA2 f (M1 x) (M1 y) = M1 $ fliftA2 f x y 473 | {-# inline fliftA2 #-} 474 | 475 | instance FApply f => FApply (Rec1 f) where 476 | fliftA2 f (Rec1 x) (Rec1 y) = Rec1 $ fliftA2 f x y 477 | {-# inline fliftA2 #-} 478 | 479 | instance Semigroup a => FApply (K1 i a) where 480 | fliftA2 _ (K1 a) (K1 b) = K1 (a <> b) 481 | {-# inline fliftA2 #-} 482 | 483 | instance Monoid a => FApplicative (K1 i a) where 484 | fpure _ = K1 mempty 485 | {-# inline fpure #-} 486 | 487 | deriving newtype instance FApplicative f => FApplicative (M1 i c f) 488 | deriving newtype instance FApplicative f => FApplicative (Rec1 f) 489 | 490 | instance (FApply f, FApply g) => FApply (f :*: g) where 491 | fliftA2 f (x :*: y) (x' :*: y') = fliftA2 f x x' :*: fliftA2 f y y' 492 | {-# inline fliftA2 #-} 493 | 494 | instance (FApplicative f, FApplicative g) => FApplicative (f :*: g) where 495 | fpure x = fpure x :*: fpure x 496 | {-# inline fpure #-} 497 | 498 | -- | We only need an 'Apply' part of an 'Applicative'. 499 | instance (Applicative f, FApply g) => FApply (f :.: g) where 500 | fliftA2 f (Comp1 x) (Comp1 y) = Comp1 (liftA2 (fliftA2 f) x y) 501 | {-# inline fliftA2 #-} 502 | 503 | instance (Applicative f, FApplicative g) => FApplicative (f :.: g) where 504 | fpure x = Comp1 (pure (fpure x)) 505 | {-# inline fpure #-} 506 | 507 | deriving newtype instance FFunctor f => FFunctor (Backwards f) 508 | deriving newtype instance FFunctor f => FFunctor (Reverse f) 509 | deriving newtype instance FFunctor f => FFunctor (Monoid.Alt f) 510 | 511 | -- to match the behavior on Appliative 512 | instance FApply f => FApply (Backwards f) where 513 | fliftA2 = \f (Backwards xs) (Backwards ys) -> Backwards $ fliftA2 (\j k -> f k j) ys xs 514 | {-# inline fliftA2 #-} 515 | 516 | deriving newtype instance FApply f => FApply (Reverse f) 517 | deriving newtype instance FApply f => FApply (Monoid.Alt f) 518 | deriving newtype instance FApplicative f => FApplicative (Backwards f) 519 | deriving newtype instance FApplicative f => FApplicative (Reverse f) 520 | deriving newtype instance FApplicative f => FApplicative (Monoid.Alt f) 521 | deriving newtype instance FFoldable f => FFoldable (Backwards f) 522 | deriving newtype instance FFoldable f => FFoldable (Monoid.Alt f) 523 | 524 | instance FFoldable f => FFoldable (Reverse f) where 525 | ffoldMap = \f -> Monoid.getDual #. ffoldMap (Monoid.Dual #. f) 526 | {-# inline ffoldMap #-} 527 | 528 | instance FTraversable f => FTraversable (Reverse f) where 529 | ftraverse = \f -> forwards #. fmap Reverse . ftraverse (Backwards #. f) .# getReverse 530 | {-# inline ftraverse #-} 531 | 532 | instance FTraversable f => FTraversable (Backwards f) where 533 | ftraverse = \f -> fmap Backwards . ftraverse f .# forwards 534 | {-# inline ftraverse #-} 535 | 536 | instance FTraversable f => FTraversable (Monoid.Alt f) where 537 | ftraverse = \f -> fmap Monoid.Alt . ftraverse f .# Monoid.getAlt 538 | {-# inline ftraverse #-} 539 | 540 | deriving newtype instance FFunctor f => FFunctor (Monoid.Ap f) 541 | deriving newtype instance FApply f => FApply (Monoid.Ap f) 542 | deriving newtype instance FApplicative f => FApplicative (Monoid.Ap f) 543 | deriving newtype instance FFoldable f => FFoldable (Monoid.Ap f) 544 | 545 | instance FTraversable f => FTraversable (Monoid.Ap f) where 546 | ftraverse = \f -> fmap Monoid.Ap . ftraverse f .# Monoid.getAp 547 | {-# inline ftraverse #-} 548 | 549 | -- * FBind 550 | 551 | newtype Coatkey a x y = Coatkey (x ~ y => a x) 552 | 553 | runCoatkey :: Coatkey a x x -> a x 554 | runCoatkey = \(Coatkey a) -> a 555 | {-# inline runCoatkey #-} 556 | 557 | class FApply f => FBind f where 558 | fbind :: f a -> (forall x. a x -> f (Coatkey b x)) -> f b 559 | 560 | -- | 'fbind' indexed only on the inner layer 561 | fbindInner :: FBind f => f a -> (forall x. a x -> f b) -> f b 562 | fbindInner = \fa f -> fbind fa \a -> ffmap (\x -> Coatkey x) $ f a 563 | {-# inline fbindInner #-} 564 | 565 | -- | 'fbind' indexed only on the outer layer 566 | fbindOuter :: FBind f => f a -> (forall x. a x -> f (Const (b x))) -> f b 567 | fbindOuter = \fa f -> fbind fa \a -> ffmap (\x -> Coatkey (getConst x)) $ f a 568 | {-# inline fbindOuter #-} 569 | 570 | newtype ViaFBind f a = ViaFBind { runViaFBind :: f a } 571 | deriving newtype FFunctor 572 | 573 | -- | Derive 'FApply' from 'fbind' and 'ffmap' 574 | instance FBind f => FApply (ViaFBind f) where 575 | fliftA2 = \f (ViaFBind fa) -> ViaFBind #. fliftM2 f fa .# runViaFBind 576 | {-# inline fliftA2 #-} 577 | 578 | -- | 579 | -- 'Applicative and Bind are enough to show 'Monad' 580 | -- 581 | -- @ 582 | -- fa 583 | -- = pure id <*> fa 584 | -- = join $ fmap (\f -> f <$> fa) (pure id) 585 | -- = join $ pure $ id <$> fa 586 | -- = join $ pure fa 587 | -- @ 588 | -- 589 | -- @ 590 | -- fa 591 | -- = fa <* pure () 592 | -- = liftA2 const fa (pure ()) 593 | -- = join $ fmap (\a -> const a <$> pure ()) fa 594 | -- = join $ fmap (\a -> pure (const a ())) fa 595 | -- = join $ fmap pure fa 596 | -- @ 597 | -- 598 | -- Likewise, 'FApplicative' and 'FBind' are enough to show 'FMonad' : 599 | -- 600 | -- @ 601 | -- fa 602 | -- = fliftA2 const fa (fpure Proxy) 603 | -- = fbind fa \a -> ffmap (\x -> Coatkey $ const a x) (fpure Proxy) 604 | -- = fbind fa \a -> ffmap (const $ Coatkey a) (fpure Proxy) 605 | -- = fbind fa \a -> fpure (Coatkey a) 606 | -- 607 | -- fa 608 | -- = fliftA2 (flip const) (fpure Proxy) fa 609 | -- = fbind (fpure Proxy) \x -> ffmap (\a -> Coatkey $ flip const x a) fa 610 | -- = fbind (fpure Proxy) \_ -> ffmap (\a -> Coatkey a) fa 611 | -- = fbind (fpure (Const fa)) (\(Const fa') -> ffmap Coatkey fa') 612 | -- @ 613 | class (FApplicative f, FBind f) => FMonad f 614 | instance (FApplicative f, FBind f) => FMonad f 615 | 616 | -- _proof :: forall f a. (FApplicative f, FBind f) => f a -> [f a] 617 | -- _proof fa = 618 | -- [ fa 619 | -- , fliftA2 const fa (fpure Proxy) 620 | -- , fbind fa \a -> ffmap (\x -> Coatkey $ const a x) (fpure Proxy) 621 | -- , fbind fa \a -> ffmap (const $ Coatkey a) (fpure Proxy) 622 | -- , fbind fa \a -> fpure (Coatkey a) 623 | 624 | -- , fa 625 | -- , fliftA2 (flip const) (fpure Proxy) fa 626 | -- , fbind (fpure Proxy) \x -> ffmap (\a -> Coatkey $ flip const x a) fa 627 | -- , fbind (fpure Proxy) \_ -> ffmap (\a -> Coatkey a) fa 628 | -- , fbind (fpure (Const fa)) (\(Const ma) -> ffmap Coatkey ma) 629 | -- ] 630 | 631 | fliftM :: FMonad f => (a ~> b) -> f a -> f b 632 | fliftM = \f fa -> fbind fa \a -> fpure $ Coatkey $ f a 633 | {-# inline fliftM #-} 634 | 635 | fliftM2 :: FBind f => (forall x. a x -> b x -> c x) -> f a -> f b -> f c 636 | fliftM2 = \f fa fb -> fbind fa \a -> ffmap (\b -> Coatkey $ f a b) fb 637 | {-# inline fliftM2 #-} 638 | 639 | newtype ViaFMonad f a = ViaFMonad { runViaFMonad :: f a } 640 | 641 | -- | Derive 'FFunctor' from 'fbind' and 'fpure' 642 | instance FMonad f => FFunctor (ViaFMonad f) where 643 | ffmap = \f -> ViaFMonad #. fliftM f .# runViaFMonad 644 | {-# inline ffmap #-} 645 | 646 | -- | Derive 'FApply' from 'fbind' and 'ffmap' 647 | instance FMonad f => FApply (ViaFMonad f) where 648 | fliftA2 = \f (ViaFMonad fa) -> ViaFMonad #. fliftM2 f fa .# runViaFMonad 649 | {-# inline fliftA2 #-} 650 | 651 | instance (GEq k, Hashable (Some k)) => FBind (DHashMap k) where 652 | fbind = \m f -> DHashMap.mapMaybeWithKey (\k -> fmap runCoatkey . DHashMap.lookup k . f) m 653 | {-# inline fbind #-} 654 | 655 | -- * WithIndex 656 | 657 | class FFunctor f => FFunctorWithIndex i f | f -> i where 658 | ifmap :: (forall x. i x -> a x -> b x) -> f a -> f b 659 | default ifmap :: FTraversableWithIndex i f => (forall x. i x -> a x -> b x) -> f a -> f b 660 | ifmap = ifmapDefault 661 | {-# inline ifmap #-} 662 | 663 | instance FFunctorWithIndex f (DSum f) where 664 | ifmap f (g :=> h) = g :=> f g h 665 | {-# inline ifmap #-} 666 | 667 | instance FFunctorWithIndex f (DHashMap f) where 668 | ifmap = DHashMap.mapWithKey 669 | {-# inline ifmap #-} 670 | 671 | ifmapDefault :: FTraversableWithIndex i f => (forall x. i x -> a x -> b x) -> f a -> f b 672 | ifmapDefault = \ f -> runIdentity #. iftraverse (\i a -> Identity (f i a)) 673 | {-# inline ifmapDefault #-} 674 | 675 | class FFoldable f => FFoldableWithIndex i f | f -> i where 676 | iffoldMap :: Monoid m => (forall x. i x -> a x -> m) -> f a -> m 677 | default iffoldMap :: (FTraversableWithIndex i f, Monoid m) => (forall x. i x -> a x -> m) -> f a -> m 678 | iffoldMap = iffoldMapDefault 679 | {-# inline iffoldMap #-} 680 | 681 | iftoList :: FFoldableWithIndex i t => t f -> [DSum i f] 682 | iftoList = iffoldMap \i a -> [i :=> a] 683 | {-# inline iftoList #-} 684 | 685 | iffoldMapDefault :: (FTraversableWithIndex i f, Monoid m) => (forall x. i x -> a x -> m) -> f a -> m 686 | iffoldMapDefault = \f -> getConst #. iftraverse (\i -> Const #. f i) 687 | {-# inline iffoldMapDefault #-} 688 | 689 | instance FFoldableWithIndex f (DSum f) where 690 | iffoldMap f (g :=> h) = f g h 691 | {-# inline iffoldMap #-} 692 | 693 | instance FFoldableWithIndex f (DHashMap f) where 694 | iffoldMap = DHashMap.foldMapWithKey 695 | {-# inline iffoldMap #-} 696 | 697 | class (FFunctorWithIndex i f, FFoldableWithIndex i f, FTraversable f) => FTraversableWithIndex i f | f -> i where 698 | iftraverse :: Applicative m => (forall x. i x -> a x -> m (b x)) -> f a -> m (f b) 699 | 700 | instance FTraversableWithIndex f (DSum f) where 701 | iftraverse f (g :=> h) = (g :=>) <$> f g h 702 | {-# inline iftraverse #-} 703 | 704 | instance FTraversableWithIndex f (DHashMap f) where 705 | iftraverse = DHashMap.traverseWithKey 706 | {-# inline iftraverse #-} 707 | 708 | -- | Eq constraints on `k` 709 | type family EqC :: k -> Constraint 710 | 711 | 712 | class (forall x. EqC x => Eq (w x)) => FEq w 713 | instance (forall x. EqC x => Eq (w x)) => FEq w 714 | 715 | type instance EqC = Eq 716 | type instance EqC = FEq 717 | 718 | -- | Ord constraints on `k` 719 | type family OrdC' :: k -> Constraint 720 | 721 | 722 | class (FEq w, forall x. OrdC x => Ord (w x)) => FOrd w 723 | instance (FEq w, forall x. OrdC x => Ord (w x)) => FOrd w 724 | 725 | type instance OrdC' = Ord 726 | type instance OrdC' = FOrd 727 | 728 | class (EqC x, OrdC' x) => OrdC x where 729 | instance (EqC x, OrdC' x) => OrdC x where 730 | 731 | ------------------------------------------------------------------------------- 732 | -- Some 733 | ------------------------------------------------------------------------------- 734 | 735 | instance FFunctor Some where 736 | ffmap = mapSome 737 | {-# inline ffmap #-} 738 | 739 | instance FFoldable Some where 740 | ffoldMap = foldSome 741 | flengthAcc len _ = len + 1 742 | {-# inline ffoldMap #-} 743 | {-# inline flengthAcc #-} 744 | 745 | instance FTraversable Some where 746 | ftraverse f (Some m) = Some <$> f m 747 | {-# inline ftraverse #-} 748 | 749 | instance FFunctor G.Some where 750 | ffmap = G.mapSome 751 | {-# inline ffmap #-} 752 | 753 | instance FFoldable G.Some where 754 | ffoldMap = G.foldSome 755 | flengthAcc len _ = len + 1 756 | {-# inline ffoldMap #-} 757 | {-# inline flengthAcc #-} 758 | 759 | instance FTraversable G.Some where 760 | ftraverse f x = G.withSome x $ fmap G.Some . f 761 | {-# inline ftraverse #-} 762 | 763 | instance FFunctor C.Some where 764 | ffmap = C.mapSome 765 | {-# inline ffmap #-} 766 | 767 | instance FFoldable C.Some where 768 | ffoldMap = C.foldSome 769 | flengthAcc len _ = len + 1 770 | {-# inline ffoldMap #-} 771 | {-# inline flengthAcc #-} 772 | 773 | instance FTraversable C.Some where 774 | ftraverse f x = C.withSome x $ fmap C.mkSome . f 775 | {-# inline ftraverse #-} 776 | 777 | -- TODO: IdentityT 778 | 779 | -- * Units 780 | 781 | instance FFunctorWithIndex U1 Some where 782 | ifmap f = mapSome (f U1) 783 | 784 | instance FFoldableWithIndex U1 Some where 785 | iffoldMap f = foldSome (f U1) 786 | 787 | instance FTraversableWithIndex U1 Some where 788 | iftraverse f = traverseSome (f U1) 789 | 790 | instance FFunctorWithIndex U1 G.Some where 791 | ifmap f = G.mapSome (f U1) 792 | 793 | instance FFoldableWithIndex U1 G.Some where 794 | iffoldMap f = G.foldSome (f U1) 795 | 796 | instance FTraversableWithIndex U1 G.Some where 797 | iftraverse f = G.traverseSome (f U1) 798 | 799 | instance FFunctorWithIndex U1 C.Some where 800 | ifmap f = C.mapSome (f U1) 801 | 802 | instance FFoldableWithIndex U1 C.Some where 803 | iffoldMap f = C.foldSome (f U1) 804 | 805 | instance FTraversableWithIndex U1 C.Some where 806 | iftraverse f = C.traverseSome (f U1) 807 | 808 | instance FFunctorWithIndex V1 U1 where 809 | ifmap = \_ U1 -> U1 810 | {-# inline ifmap #-} 811 | 812 | instance FFoldableWithIndex V1 U1 where 813 | iffoldMap = \_ _ -> mempty 814 | {-# inline iffoldMap #-} 815 | 816 | instance FTraversableWithIndex V1 U1 where 817 | iftraverse = \_ U1 -> pure U1 818 | {-# inline iftraverse #-} 819 | 820 | instance FFunctorWithIndex V1 Proxy where 821 | ifmap = \_ _ -> Proxy 822 | {-# inline ifmap #-} 823 | 824 | instance FFoldableWithIndex V1 Proxy where 825 | iffoldMap = \_ _ -> mempty 826 | {-# inline iffoldMap #-} 827 | 828 | instance FTraversableWithIndex V1 Proxy where 829 | iftraverse = \_ _ -> pure Proxy 830 | {-# inline iftraverse #-} 831 | -- * Void 832 | 833 | instance FFunctorWithIndex V1 V1 where 834 | ifmap = \_ -> \case 835 | {-# inline ifmap #-} 836 | 837 | instance FFoldableWithIndex V1 V1 where 838 | iffoldMap = \_ -> \case 839 | {-# inline iffoldMap #-} 840 | 841 | instance FTraversableWithIndex V1 V1 where 842 | iftraverse = \_ -> \case 843 | {-# inline iftraverse #-} 844 | 845 | -- * Constants 846 | 847 | instance FFunctorWithIndex V1 (Const e) where 848 | ifmap = \_ -> coerce 849 | {-# inline ifmap #-} 850 | 851 | instance FFoldableWithIndex V1 (Const e) where 852 | iffoldMap = \_ _ -> mempty 853 | {-# inline iffoldMap #-} 854 | 855 | instance FTraversableWithIndex V1 (Const e) where 856 | iftraverse = \_ -> pure .# (Const . getConst) 857 | {-# inline iftraverse #-} 858 | 859 | instance FFunctorWithIndex V1 (Constant e) where 860 | ifmap = \_ -> coerce 861 | {-# inline ifmap #-} 862 | 863 | instance FFoldableWithIndex V1 (Constant e) where 864 | iffoldMap = \_ _ -> mempty 865 | {-# inline iffoldMap #-} 866 | 867 | instance FTraversableWithIndex V1 (Constant e) where 868 | iftraverse = \_ -> pure .# (Constant . getConstant) 869 | {-# inline iftraverse #-} 870 | 871 | -- * K1 872 | 873 | instance FFunctorWithIndex V1 (K1 i c) where 874 | ifmap = \_ -> coerce 875 | {-# inline ifmap #-} 876 | 877 | instance FFoldableWithIndex V1 (K1 i c) where 878 | iffoldMap = \_ _ -> mempty 879 | {-# inline iffoldMap #-} 880 | 881 | instance FTraversableWithIndex V1 (K1 i c) where 882 | iftraverse = \_ -> pure .# (K1 . unK1) 883 | {-# inline iftraverse #-} 884 | 885 | -- * Products 886 | 887 | instance (FFunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (i :+: j) (f :*: g) where 888 | ifmap = \f (x :*: y) -> ifmap (f . L1) x :*: ifmap (f . R1) y 889 | {-# inline ifmap #-} 890 | 891 | instance (FFoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (i :+: j) (f :*: g) where 892 | iffoldMap = \f (x :*: y) -> iffoldMap (f . L1) x <> iffoldMap (f . R1) y 893 | {-# inline iffoldMap #-} 894 | 895 | instance (FTraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (i :+: j) (f :*: g) where 896 | iftraverse = \f (x :*: y) -> liftA2 (:*:) (iftraverse (f . L1) x) (iftraverse (f . R1) y) 897 | {-# inline iftraverse #-} 898 | 899 | instance (FFunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (i :+: j) (Product f g) where 900 | ifmap = \f (Pair x y) -> Pair (ifmap (f . L1) x) (ifmap (f . R1) y) 901 | {-# inline ifmap #-} 902 | 903 | instance (FFoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (i :+: j) (Product f g) where 904 | iffoldMap = \f (Pair x y) -> iffoldMap (f . L1) x <> iffoldMap (f . R1) y 905 | {-# inline iffoldMap #-} 906 | 907 | instance (FTraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (i :+: j) (Product f g) where 908 | iftraverse = \f (Pair x y) -> liftA2 Pair (iftraverse (f . L1) x) (iftraverse (f . R1) y) 909 | {-# inline iftraverse #-} 910 | 911 | -- * Sums 912 | 913 | instance (FFunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (i :+: j) (f :+: g) where 914 | ifmap = \f -> \case 915 | L1 x -> L1 (ifmap (f . L1) x) 916 | R1 y -> R1 (ifmap (f . R1) y) 917 | {-# inline ifmap #-} 918 | 919 | instance (FFoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (i :+: j) (f :+: g) where 920 | iffoldMap = \f -> \case 921 | L1 x -> iffoldMap (f . L1) x 922 | R1 y -> iffoldMap (f . R1) y 923 | {-# inline iffoldMap #-} 924 | 925 | instance (FTraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (i :+: j) (f :+: g) where 926 | iftraverse = \f -> \case 927 | L1 x -> L1 <$> iftraverse (f . L1) x 928 | R1 y -> R1 <$> iftraverse (f . R1) y 929 | {-# inline iftraverse #-} 930 | 931 | instance (FFunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (i :+: j) (Sum f g) where 932 | ifmap = \f -> \case 933 | InL x -> InL (ifmap (f . L1) x) 934 | InR y -> InR (ifmap (f . R1) y) 935 | {-# inline ifmap #-} 936 | 937 | instance (FFoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (i :+: j) (Sum f g) where 938 | iffoldMap = \f -> \case 939 | InL x -> iffoldMap (f . L1) x 940 | InR y -> iffoldMap (f . R1) y 941 | {-# inline iffoldMap #-} 942 | 943 | instance (FTraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (i :+: j) (Sum f g) where 944 | iftraverse = \f -> \case 945 | InL x -> InL <$> iftraverse (f . L1) x 946 | InR y -> InR <$> iftraverse (f . R1) y 947 | {-# inline iftraverse #-} 948 | 949 | -- * Composition 950 | 951 | instance (FunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (Const i :*: j) (f :.: g) where 952 | ifmap = \f -> Comp1 #. imap (\i -> ifmap (f . (Const i :*:))) .# unComp1 953 | {-# inline ifmap #-} 954 | 955 | instance (FoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (Const i :*: j) (f :.: g) where 956 | iffoldMap = \f -> ifoldMap (\i -> iffoldMap (f . (Const i :*:))) .# unComp1 957 | {-# inline iffoldMap #-} 958 | 959 | instance (TraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (Const i :*: j) (f :.: g) where 960 | iftraverse = \f -> fmap Comp1 . itraverse (\i -> iftraverse (f . (Const i :*:))) .# unComp1 961 | {-# inline iftraverse #-} 962 | 963 | instance (FunctorWithIndex i f, FFunctorWithIndex j g) => FFunctorWithIndex (Const i :*: j) (Compose f g) where 964 | ifmap = \f -> Compose #. imap (\i -> ifmap (f . (Const i :*:))) .# getCompose 965 | {-# inline ifmap #-} 966 | 967 | instance (FoldableWithIndex i f, FFoldableWithIndex j g) => FFoldableWithIndex (Const i :*: j) (Compose f g) where 968 | iffoldMap = \f -> ifoldMap (\i -> iffoldMap (f . (Const i :*:))) .# getCompose 969 | {-# inline iffoldMap #-} 970 | 971 | instance (TraversableWithIndex i f, FTraversableWithIndex j g) => FTraversableWithIndex (Const i :*: j) (Compose f g) where 972 | iftraverse = \f -> fmap Compose . itraverse (\i -> iftraverse (f . (Const i :*:))) .# getCompose 973 | {-# inline iftraverse #-} 974 | 975 | -- * Rec1 976 | 977 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (Rec1 f) 978 | deriving newtype instance FFoldableWithIndex i f => FFoldableWithIndex i (Rec1 f) 979 | instance FTraversableWithIndex i f => FTraversableWithIndex i (Rec1 f) where 980 | iftraverse = \f -> fmap Rec1 . iftraverse f .# unRec1 981 | {-# inline iftraverse #-} 982 | 983 | -- * M1 984 | 985 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (M1 j c f) 986 | deriving newtype instance FFoldableWithIndex i f => FFoldableWithIndex i (M1 j c f) 987 | instance FTraversableWithIndex i f => FTraversableWithIndex i (M1 j c f) where 988 | iftraverse = \f -> fmap M1 . iftraverse f .# unM1 989 | {-# inline iftraverse #-} 990 | 991 | -- * Alt 992 | 993 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (Monoid.Alt f) 994 | deriving newtype instance FFoldableWithIndex i f => FFoldableWithIndex i (Monoid.Alt f) 995 | instance FTraversableWithIndex i f => FTraversableWithIndex i (Monoid.Alt f) where 996 | iftraverse = \f -> fmap Monoid.Alt . iftraverse f .# Monoid.getAlt 997 | {-# inline iftraverse #-} 998 | 999 | -- * Ap 1000 | 1001 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (Monoid.Ap f) 1002 | deriving newtype instance FFoldableWithIndex i f => FFoldableWithIndex i (Monoid.Ap f) 1003 | instance FTraversableWithIndex i f => FTraversableWithIndex i (Monoid.Ap f) where 1004 | iftraverse = \f -> fmap Monoid.Ap . iftraverse f .# Monoid.getAp 1005 | {-# inline iftraverse #-} 1006 | 1007 | -- * Backwards 1008 | 1009 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (Backwards f) 1010 | deriving newtype instance FFoldableWithIndex i f => FFoldableWithIndex i (Backwards f) 1011 | instance FTraversableWithIndex i f => FTraversableWithIndex i (Backwards f) where 1012 | iftraverse = \f -> fmap Backwards . iftraverse f .# forwards 1013 | {-# inline iftraverse #-} 1014 | 1015 | -- * Reverse 1016 | 1017 | deriving newtype instance FFunctorWithIndex i f => FFunctorWithIndex i (Reverse f) 1018 | instance FFoldableWithIndex i f => FFoldableWithIndex i (Reverse f) where 1019 | iffoldMap = \f -> Monoid.getDual #. iffoldMap (\i -> Monoid.Dual #. f i) .# getReverse 1020 | {-# inline iffoldMap #-} 1021 | 1022 | instance FTraversableWithIndex i f => FTraversableWithIndex i (Reverse f) where 1023 | iftraverse = \f -> forwards #. fmap Reverse . iftraverse (\i -> Backwards #. f i) .# getReverse 1024 | {-# inline iftraverse #-} 1025 | --------------------------------------------------------------------------------