invariant-0.6.3/ 0000755 0000000 0000000 00000000000 07346545000 011704 5 ustar 00 0000000 0000000 invariant-0.6.3/CHANGELOG.md 0000644 0000000 0000000 00000012575 07346545000 013527 0 ustar 00 0000000 0000000 # 0.6.3 [2024.03.19]
* Support building with `template-haskell-2.22.*` (GHC 9.10).
# 0.6.2 [2023.08.06]
* The Template Haskell machinery now uses `TemplateHaskellQuotes` when
building with GHC 8.0+ instead of manually constructing each Template Haskell
`Name`. A consequence of this is that `invariant` will now build with GHC
9.8, as `TemplateHaskellQuotes` abstracts over some internal Template Haskell
changes introduced in 9.8.
# 0.6.1 [2023.02.27]
* Support `th-abstraction-0.5.*`.
# 0.6 [2022.07.03]
* Loosen the `Monad` constraint in the `Invariant(2)` instances for
`Kleisli` to an `Invariant` constraint.
* Loosen the `Comonad` constraint in the `Invariant2` instance for `Cokleisli`
to an `Invariant` constraint.
* Add `Invariant` instances for `PastroSum`, `CopastroSum`, `Environment`,
`FreeMapping`, `Pastro`, and `FreeTraversing` from the `profunctors` library.
* Add `Invariant(2)` instances for `Copastro` and `Coyoneda` from the
`profunctors` library.
# 0.5.6 [2022.05.07]
* Add `InvariantProfunctor` and `InvariantArrow` newtypes that admit
implementations of `invmap` that only require `Profunctor` or `Arrow`
constraints, respectively. Also add top-level `invmapProfunctor` and
`invmapArrow` functions.
# 0.5.5 [2021.11.01]
* Allow building with GHC 9.2.
* Allow building with `transformers-0.6.*`.
# 0.5.4 [2020.10.01]
* Fix a bug in which `deriveInvariant2` would fail on certain data types with
three or parameters if the first two parameters had phantom roles.
* Fix a bug in which `deriveInvariant(2)` would fail on sufficiently complex
uses of rank-n types in constructor fields.
* Fix a bug in which `deriveInvariant(2)` would needlessly reject data types
whose two last type parameters appear as oversaturated arguments to a type
family.
# 0.5.3 [2019.05.02]
* Implement `foldMap'` in the `Foldable` instance for `WrappedFunctor` when
building with `base-4.13` or later.
# 0.5.2 [2019.04.26]
* Support `th-abstraction-0.3.0.0` or later.
* Only incur a `semigroups` dependency on old GHCs.
# 0.5.1 [2018.07.15]
* Depend on `QuickCheck-2.11` or later in the test suite.
* Some Haddock fixes in `Data.Functor.Invariant.TH`.
# 0.5 [2017.12.07]
* `Data.Functor.Invariant.TH` now derives `invmap(2)` implementations for empty
data types that are strict in the argument.
* When using `Data.Functor.Invariant.TH` to derive `Invariant(2)` instances for
data types where the last type variables are at phantom roles, generated
`invmap(2)` implementations now use `coerce` for efficiency.
* Add `Options` to `Data.Functor.Invariant.TH`, along with variants of existing
functions that take `Options` as an argument. For now, the only configurable
option is whether derived instances for empty data types should use the
`EmptyCase` extension (this is disabled by default).
# 0.4.3 [2017.07.31]
* Add `Invariant(2)` instances for `Data.Profunctor.Yoneda.Yoneda`.
# 0.4.2 [2017.04.24]
* `invariant.cabal` used to incorrectly state the license was BSD3 when it was
in fact BSD2. This is now fixed.
# 0.4.1
* Fix the `Invariant V1` instance so as to `seq` its argument
* Allow building with `template-haskell-2.12`
# 0.4
* Allow TH derivation of `Invariant(2)` instances for datatypes containing
unboxed tuple types
* Ensure `Invariant(2)` instances are in-scope when importing
`Data.Functor.Invariant`
* Add `Invariant` and `Invariant2` instances for `Kleisli` and `Cokleisli`
* Add `Category` and `Arrow`-like instances for `WrappedProfunctor`
# 0.3.1
* Rewrote `Data.Functor.Invariant.TH`'s type inferencer. This avoids a nasty
GHC 7.8-specific bug involving derived `Invariant(2)` instances for data
families.
* Add `Invariant` instances for `Data.Complex.Complex`, `Data.Monoid.Product`,
and `Data.Monoid.Sum`
# 0.3
* Require `bifunctors-5.2` and `profunctors-5.2`. Add `Invariant(2)` instances
for newly introduced datatypes from those packages.
* Add `ProfunctorFunctor`, `ProfunctorMonad`, `ProfunctorComonad`, `Mapping`,
and `Traversing` instances for `WrappedProfunctor`
* Add `StateVar` as a dependency. Add `Invariant` instances for `StateVar` and
`SettableStateVar`.
* Add `Invariant` instances for `URec` (added to `GHC.Generics` in
`base-4.9.0.0`)
# 0.2.2
* Add `genericInvmap` function (and make it the default implementation of
`invmap` for `Invariant` instances) on GHC 7.2 or later
* Make `Tagged` instance poly-kinded
# 0.2.1
* Add `Foldable` and `Traversable` instances for `WrappedFunctor`
* Fixed build on GHC HEAD
# 0.2
* Support deriving `Invariant` and `Invariant2` instances with Template Haskell
* Added `invmapFunctor`, `invmapContravariant`, `invmap2Bifunctor`, and
`invmap2Profunctor` to make defining `Invmap` and `Invmap2` instances
somewhat easier
* Added `WrappedFunctor`, `WrappedContravariant`, `WrappedBifunctor`, and
`WrappedProfunctor` data types to allow use of `invmap` and `invmap2` for
data types that aren't `Invariant` or `Invariant2` instances.
* Added `Invariant` instances for lazy `ST`, `ArrowMonad`, `Handler`,
`Identity`, `First`, `Last`, `Alt`, `Proxy`, `ArgDescr`, `ArgOrder`, and
`OptDescr`
* Added `Invariant` and `Invariant2` instances for data types in the `array`,
`bifunctors`, `containers`, `profunctors`, `semigroups`, `stm`, `tagged`,
`transformers`, and `unordered-containers` libraries
# 0.1.2
* Add `Invariant` instances for `Dual` and `Endo`
# 0.1.1
* Bump `contravariant` upper version bounds
# 0.1.0
* Initial commit
invariant-0.6.3/LICENSE 0000644 0000000 0000000 00000002446 07346545000 012717 0 ustar 00 0000000 0000000 Copyright (c) 2012-2017, University of Kansas
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
invariant-0.6.3/README.md 0000644 0000000 0000000 00000001646 07346545000 013172 0 ustar 00 0000000 0000000 # `invariant`
[][Hackage: invariant]
[](http://packdeps.haskellers.com/reverse/invariant)
[][Haskell.org]
[][tl;dr Legal: BSD3]
[](https://github.com/nfrisby/invariant-functors/actions?query=workflow%3AHaskell-CI)
[Hackage: invariant]:
http://hackage.haskell.org/package/invariant
"invariant package on Hackage"
[Haskell.org]:
http://www.haskell.org
"The Haskell Programming Language"
[tl;dr Legal: BSD3]:
https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29
"BSD 3-Clause License (Revised)"
Haskell98 invariant functors
invariant-0.6.3/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 013341 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
invariant-0.6.3/invariant.cabal 0000644 0000000 0000000 00000007003 07346545000 014663 0 ustar 00 0000000 0000000 name: invariant
version: 0.6.3
synopsis: Haskell98 invariant functors
description: Haskell98 invariant functors (also known as exponential functors).
.
For more information, see Edward Kmett's article \"Rotten Bananas\":
.
category: Control, Data
license: BSD2
license-file: LICENSE
homepage: https://github.com/nfrisby/invariant-functors
bug-reports: https://github.com/nfrisby/invariant-functors/issues
author: Nicolas Frisby
maintainer: Nicolas Frisby ,
Ryan Scott
build-type: Simple
cabal-version: >= 1.10
tested-with: GHC == 7.0.4
, GHC == 7.2.2
, GHC == 7.4.2
, GHC == 7.6.3
, GHC == 7.8.4
, GHC == 7.10.3
, GHC == 8.0.2
, GHC == 8.2.2
, GHC == 8.4.4
, GHC == 8.6.5
, GHC == 8.8.4
, GHC == 8.10.7
, GHC == 9.0.2
, GHC == 9.2.8
, GHC == 9.4.8
, GHC == 9.6.4
, GHC == 9.8.2
, GHC == 9.10.1
extra-source-files: CHANGELOG.md, README.md
source-repository head
type: git
location: https://github.com/nfrisby/invariant-functors
library
exposed-modules: Data.Functor.Invariant
, Data.Functor.Invariant.TH
other-modules: Data.Functor.Invariant.TH.Internal
, Paths_invariant
hs-source-dirs: src
default-language: Haskell2010
build-depends: array >= 0.3 && < 0.6
, base >= 4 && < 5
, bifunctors >= 5.2 && < 6
, comonad >= 5 && < 6
, containers >= 0.1 && < 0.8
, contravariant >= 0.5 && < 2
, ghc-prim
, profunctors >= 5.2.1 && < 6
, StateVar >= 1.1 && < 2
, stm >= 2.2 && < 3
, tagged >= 0.7.3 && < 1
, template-haskell >= 2.4 && < 2.23
, th-abstraction >= 0.4 && < 0.8
, transformers >= 0.2 && < 0.7
, transformers-compat >= 0.3 && < 1
, unordered-containers >= 0.2.4 && < 0.3
ghc-options: -Wall
if !impl(ghc >= 8.0)
build-depends: semigroups >= 0.16.2 && < 1
test-suite spec
type: exitcode-stdio-1.0
hs-source-dirs: test
default-language: Haskell2010
main-is: Spec.hs
other-modules: InvariantSpec
THSpec
build-depends: base >= 4 && < 5
, hspec >= 1.8
, invariant
, QuickCheck >= 2.11 && < 3
, template-haskell
build-tool-depends: hspec-discover:hspec-discover
ghc-options: -Wall
if impl(ghc >= 8.6)
ghc-options: -Wno-star-is-type
invariant-0.6.3/src/Data/Functor/ 0000755 0000000 0000000 00000000000 07346545000 014764 5 ustar 00 0000000 0000000 invariant-0.6.3/src/Data/Functor/Invariant.hs 0000644 0000000 0000000 00000116431 07346545000 017261 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
#if !(MIN_VERSION_base(4,16,0)) || !(MIN_VERSION_transformers(0,6,0))
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif
#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702
#if GHC_GENERICS_OK
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
{-|
Module: Data.Functor.Invariant
Copyright: (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Portable
Haskell98 invariant functors (also known as exponential functors).
For more information, see Edward Kmett's article \"Rotten Bananas\":
-}
module Data.Functor.Invariant
( -- * @Invariant@
Invariant(..)
, invmapFunctor
#if GHC_GENERICS_OK
-- ** @GHC.Generics@
-- $ghcgenerics
, genericInvmap
#endif
, WrappedFunctor(..)
, invmapContravariant
, invmapProfunctor
, invmapArrow
, WrappedContravariant(..)
, InvariantProfunctor(..)
, InvariantArrow(..)
-- * @Invariant2@
, Invariant2(..)
, invmap2Bifunctor
, WrappedBifunctor(..)
, invmap2Profunctor
, WrappedProfunctor(..)
) where
-- base
import Control.Applicative as App
import qualified Control.Arrow as Arr
import Control.Arrow hiding (first, second)
import qualified Control.Category as Cat
import Control.Exception (Handler(..))
import Control.Monad (MonadPlus(..), liftM)
import qualified Control.Monad.ST as Strict (ST)
import qualified Control.Monad.ST.Lazy as Lazy (ST)
#if MIN_VERSION_base(4,4,0)
import Data.Complex (Complex(..))
#endif
import qualified Data.Foldable as F (Foldable(..))
import qualified Data.Functor.Compose as Functor (Compose(..))
import Data.Functor.Identity (Identity)
import Data.Functor.Product as Functor (Product(..))
import Data.Functor.Sum as Functor (Sum(..))
#if __GLASGOW_HASKELL__ < 711
import Data.Ix (Ix)
#endif
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Monoid as Monoid (First(..), Last(..), Product(..), Sum(..))
#if MIN_VERSION_base(4,8,0)
import Data.Monoid (Alt(..))
#endif
import Data.Monoid (Dual(..), Endo(..))
import Data.Proxy (Proxy(..))
import qualified Data.Semigroup as Semigroup (First(..), Last(..))
#if !(MIN_VERSION_base(4,16,0))
import qualified Data.Semigroup as Semigroup (Option(..))
#endif
import Data.Semigroup (Min(..), Max(..), Arg(..))
import qualified Data.Traversable as T (Traversable(..))
#if GHC_GENERICS_OK
import GHC.Generics
#endif
import System.Console.GetOpt as GetOpt
import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadPrec (ReadPrec)
-- array
import Data.Array (Array)
-- bifunctors
import Data.Bifunctor
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Fix
import Data.Bifunctor.Flip
import Data.Bifunctor.Join
import Data.Bifunctor.Joker
import qualified Data.Bifunctor.Product as Bifunctor
import qualified Data.Bifunctor.Sum as Bifunctor
import Data.Bifunctor.Tannen
import Data.Bifunctor.Wrapped
-- comonad
import Control.Comonad (Cokleisli(..))
-- containers
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Sequence (Seq, ViewL, ViewR)
import Data.Tree (Tree)
-- contravariant
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Compose as Contravariant
import Data.Functor.Contravariant.Divisible
-- profunctors
import Data.Profunctor as Pro
import Data.Profunctor.Cayley
import Data.Profunctor.Choice
import Data.Profunctor.Closed
import Data.Profunctor.Composition
import Data.Profunctor.Mapping
import Data.Profunctor.Monad
import Data.Profunctor.Rep
import Data.Profunctor.Ran
import Data.Profunctor.Strong
import Data.Profunctor.Traversing
import Data.Profunctor.Unsafe
import Data.Profunctor.Yoneda
-- StateVar
import Data.StateVar (StateVar(..), SettableStateVar(..))
-- stm
import Control.Concurrent.STM (STM)
-- tagged
import Data.Tagged (Tagged(..))
-- transformers
import Control.Applicative.Backwards (Backwards(..))
import Control.Applicative.Lift (Lift(..))
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
#if !(MIN_VERSION_transformers(0,6,0))
import Control.Monad.Trans.Error (ErrorT(..))
import Control.Monad.Trans.List (ListT, mapListT)
#endif
import Data.Functor.Constant (Constant(..))
import Data.Functor.Reverse (Reverse(..))
-- unordered-containers
import Data.HashMap.Lazy (HashMap)
-------------------------------------------------------------------------------
-- The Invariant class
-------------------------------------------------------------------------------
-- | Any @* -> *@ type parametric in the argument permits an instance of
-- @Invariant@.
--
-- Instances should satisfy the following laws:
--
-- > invmap id id = id
-- > invmap f2 f2' . invmap f1 f1' = invmap (f2 . f1) (f1' . f2')
class Invariant f where
invmap :: (a -> b) -> (b -> a) -> f a -> f b
#if GHC_GENERICS_OK
default invmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
invmap = genericInvmap
#endif
-- | Every 'Functor' is also an 'Invariant' functor.
invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap
-- | Every 'Contravariant' functor is also an 'Invariant' functor.
invmapContravariant :: Contravariant f => (a -> b) -> (b -> a) -> f a -> f b
invmapContravariant = const contramap
-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
invmapProfunctor :: Profunctor p => (a -> b) -> (b -> a) -> p a a -> p b b
invmapProfunctor = flip dimap
-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
invmapArrow :: Arrow arr => (a -> b) -> (b -> a) -> arr a a -> arr b b
invmapArrow fn1 fn2 arrow = arr fn1 Cat.. arrow Cat.. arr fn2
-------------------------------------------------------------------------------
-- Invariant instances
-------------------------------------------------------------------------------
instance Invariant Maybe where invmap = invmapFunctor
instance Invariant [] where invmap = invmapFunctor
instance Invariant IO where invmap = invmapFunctor
instance Invariant (Strict.ST s) where invmap = invmapFunctor
instance Invariant (Lazy.ST s) where invmap = invmapFunctor
instance Invariant ReadP where invmap = invmapFunctor
instance Invariant ReadPrec where invmap = invmapFunctor
instance Invariant ((->) a) where invmap = invmapFunctor
instance Invariant (Either a) where invmap = invmapFunctor
instance Invariant ((,) a) where invmap = invmapFunctor
instance Invariant ((,,) a b) where invmap f _ ~(a, b, x) = (a, b, f x)
instance Invariant ((,,,) a b c) where
invmap f _ ~(a, b, c, x) = (a, b, c, f x)
instance Invariant ((,,,,) a b c d) where
invmap f _ ~(a, b, c, d, x) = (a, b, c, d, f x)
-- | from "Control.Applicative"
instance Invariant (Const a) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Invariant ZipList where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Monad m => Invariant (WrappedMonad m) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant (App.WrappedArrow arr a) where
invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x)
-- | from "Control.Arrow"
instance
#if MIN_VERSION_base(4,4,0)
Arrow a
#else
ArrowApply a
#endif
=> Invariant (ArrowMonad a) where
invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f)
-- | from "Control.Arrow"
instance Invariant m => Invariant (Kleisli m a) where
invmap f g (Kleisli m) = Kleisli (invmap f g . m)
-- | from "Control.Exception"
instance Invariant Handler where
invmap f _ (Handler h) = Handler (fmap f . h)
#if MIN_VERSION_base(4,4,0)
-- | from "Data.Complex"
instance Invariant Complex where
invmap f _ (r :+ i) = f r :+ f i
#endif
-- | from "Data.Functor.Compose"
instance (Invariant f, Invariant g) => Invariant (Functor.Compose f g) where
invmap f g (Functor.Compose x) =
Functor.Compose (invmap (invmap f g) (invmap g f) x)
-- | from "Data.Functor.Identity"
instance Invariant Identity where
invmap = invmapFunctor
-- | from "Data.Functor.Product"
instance (Invariant f, Invariant g) => Invariant (Functor.Product f g) where
invmap f g (Functor.Pair x y) = Functor.Pair (invmap f g x) (invmap f g y)
-- | from "Data.Functor.Sum"
instance (Invariant f, Invariant g) => Invariant (Functor.Sum f g) where
invmap f g (InL x) = InL (invmap f g x)
invmap f g (InR y) = InR (invmap f g y)
-- | from "Data.List.NonEmpty"
instance Invariant NonEmpty where
invmap = invmapFunctor
-- | from "Data.Monoid"
instance Invariant Dual where
invmap f _ (Dual x) = Dual (f x)
-- | from "Data.Monoid"
instance Invariant Endo where
invmap f g (Endo x) = Endo (f . x . g)
-- | from "Data.Monoid"
instance Invariant Monoid.First where
invmap f g (Monoid.First x) = Monoid.First (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Last where
invmap f g (Monoid.Last x) = Monoid.Last (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Product where
invmap f _ (Monoid.Product x) = Monoid.Product (f x)
-- | from "Data.Monoid"
instance Invariant Monoid.Sum where
invmap f _ (Monoid.Sum x) = Monoid.Sum (f x)
#if MIN_VERSION_base(4,8,0)
-- | from "Data.Monoid"
instance Invariant f => Invariant (Alt f) where
invmap f g (Alt x) = Alt (invmap f g x)
#endif
-- | from "Data.Proxy"
instance Invariant Proxy where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Min where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Max where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.First where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.Last where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant (Arg a) where
invmap = invmapFunctor
#if !(MIN_VERSION_base(4,16,0))
-- | from "Data.Semigroup"
instance Invariant Semigroup.Option where
invmap = invmapFunctor
#endif
-- | from "System.Console.GetOpt"
instance Invariant ArgDescr where
invmap f _ (NoArg a) = NoArg (f a)
invmap f _ (ReqArg g s) = ReqArg (f . g) s
invmap f _ (OptArg g s) = OptArg (f . g) s
-- | from "System.Console.GetOpt"
instance Invariant ArgOrder where
invmap _ _ RequireOrder = RequireOrder
invmap _ _ Permute = Permute
invmap f _ (ReturnInOrder g) = ReturnInOrder (f . g)
-- | from "System.Console.GetOpt"
instance Invariant OptDescr where
invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c
-- | from the @array@ package
instance
#if __GLASGOW_HASKELL__ < 711
Ix i =>
#endif
Invariant (Array i) where
invmap = invmapFunctor
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant g) => Invariant (Biff p f g a) where
invmap f g = Biff . invmap2 id id (invmap f g) (invmap g f) . runBiff
-- | from the @bifunctors@ package
instance Invariant (Clown f a) where
invmap = invmapFunctor
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Fix p) where
invmap f g = In . invmap2 (invmap f g) (invmap g f) f g . out
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Flip p a) where
invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Join p) where
invmap f g = Join . invmap2 f g f g . runJoin
-- | from the @bifunctors@ package
instance Invariant g => Invariant (Joker g a) where
invmap f g = Joker . invmap f g . runJoker
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where
invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant (WrappedBifunctor p a) where
invmap = invmap2 id id
-- | from the @comonad@ package
instance Invariant (Cokleisli w a) where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant IntMap where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant (Map k) where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Seq where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewL where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewR where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Tree where
invmap = invmapFunctor
-- | from the @contravariant@ package
instance Invariant Predicate where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Comparison where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Equivalence where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant (Op a) where invmap = invmapContravariant
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (Contravariant.Compose f g) where
invmap f g (Contravariant.Compose x) =
Contravariant.Compose $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeCF f g) where
invmap f g (ComposeCF x) = ComposeCF $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeFC f g) where
invmap f g (ComposeFC x) = ComposeFC $ invmap (invmap f g) (invmap g f) x
-- | from the @profunctors@ package
instance Invariant f => Invariant (Star f a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Costar f a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Arrow arr => Invariant (Pro.WrappedArrow arr a) where
invmap f _ (Pro.WrapArrow x) = Pro.WrapArrow $ ((arr f) Cat.. x)
-- | from the @profunctors@ package
instance Invariant (Forget r a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Closure p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Environment p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Codensity p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Coprep p) where
invmap f g (Coprep h) = Coprep (h . invmap2 g f id id)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Prep p) where
invmap f g (Prep x p) = Prep x (invmap2 id id f g p)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Procompose p q a) where
invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Rift p q a) where
invmap bd db (Rift f) = Rift (f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance Invariant2 q => Invariant (Ran p q a) where
invmap bd db (Ran f) = Ran (invmap2 id id bd db . f)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Tambara p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (PastroSum p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (FreeMapping p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (FreeTraversing p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Pastro p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Cotambara p a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant (Copastro p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (CopastroSum p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (CotambaraSum p a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (TambaraSum p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Yoneda p a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant (Coyoneda p a) where
invmap = invmap2 id id
-- | from the @StateVar@ package
instance Invariant StateVar where
invmap f g (StateVar ga sa) = StateVar (fmap f ga) (lmap g sa)
-- | from the @StateVar@ package
instance Invariant SettableStateVar where
invmap = invmapContravariant
-- | from the @stm@ package
instance Invariant STM where
invmap = invmapFunctor
-- | from the @tagged@ package
instance Invariant (Tagged s) where
invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Backwards f) where
invmap f g (Backwards a) = Backwards (invmap f g a)
-- | from the @transformers@ package
instance Invariant f => Invariant (Lift f) where
invmap f _ (Pure x) = Pure (f x)
invmap f g (Other y) = Other (invmap f g y)
-- | from the @transformers@ package
instance Invariant (ContT r m) where
invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant m => Invariant (ExceptT e m) where
invmap f g = ExceptT . invmap (invmap f g) (invmap g f) . runExceptT
-- | from the @transformers@ package
instance Invariant m => Invariant (IdentityT m) where
invmap f g = mapIdentityT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (MaybeT m) where
invmap f g = mapMaybeT $ invmap (invmap f g) (invmap g f)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.RWST r w s m) where
invmap f g m = Lazy.RWST $ \r s ->
invmap (mapFstTriple f) (mapFstTriple g) $ Lazy.runRWST m r s
where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
mapFstTriple h ~(a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.RWST r w s m) where
invmap f g m = Strict.RWST $ \r s ->
invmap (mapFstTriple f) (mapFstTriple g) $ Strict.runRWST m r s
where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
mapFstTriple h (a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (ReaderT r m) where
invmap f g = mapReaderT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.StateT s m) where
invmap f g m = Lazy.StateT $ \s ->
invmap (mapFstPair f) (mapFstPair g) $ Lazy.runStateT m s
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h ~(a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.StateT s m) where
invmap f g m = Strict.StateT $ \s ->
invmap (mapFstPair f) (mapFstPair g) $ Strict.runStateT m s
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h (a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.WriterT w m) where
invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h ~(a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.WriterT w m) where
invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h (a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant (Constant a) where
invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Reverse f) where
invmap f g (Reverse a) = Reverse (invmap f g a)
#if !(MIN_VERSION_transformers(0,6,0))
-- | from the @transformers@ package
instance Invariant m => Invariant (ErrorT e m) where
invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT
-- | from the @transformers@ package
instance Invariant m => Invariant (ListT m) where
invmap f g = mapListT $ invmap (invmap f g) (invmap g f)
#endif
-- | from the @unordered-containers@ package
instance Invariant (HashMap k) where
invmap = invmapFunctor
-------------------------------------------------------------------------------
-- WrappedFunctor
-------------------------------------------------------------------------------
-- | Wrap a 'Functor' to be used as a member of 'Invariant'.
newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }
deriving (Eq, Ord, Read, Show)
instance Functor f => Invariant (WrappedFunctor f) where
invmap = invmapFunctor
instance Functor f => Functor (WrappedFunctor f) where
fmap f = WrapFunctor . fmap f . unwrapFunctor
x <$ WrapFunctor f = WrapFunctor (x <$ f)
instance Applicative f => Applicative (WrappedFunctor f) where
pure = WrapFunctor . pure
WrapFunctor f <*> WrapFunctor x = WrapFunctor (f <*> x)
WrapFunctor a *> WrapFunctor b = WrapFunctor (a *> b)
WrapFunctor a <* WrapFunctor b = WrapFunctor (a <* b)
instance Alternative f => Alternative (WrappedFunctor f) where
empty = WrapFunctor empty
WrapFunctor x <|> WrapFunctor y = WrapFunctor (x <|> y)
some = WrapFunctor . some . unwrapFunctor
many = WrapFunctor . many . unwrapFunctor
instance Monad m => Monad (WrappedFunctor m) where
WrapFunctor x >>= f = WrapFunctor (x >>= unwrapFunctor . f)
#if !(MIN_VERSION_base(4,11,0))
return = WrapFunctor . return
WrapFunctor a >> WrapFunctor b = WrapFunctor (a >> b)
#endif
instance MonadPlus m => MonadPlus (WrappedFunctor m) where
mzero = WrapFunctor mzero
WrapFunctor x `mplus` WrapFunctor y = WrapFunctor (x `mplus` y)
instance F.Foldable f => F.Foldable (WrappedFunctor f) where
fold = F.fold . unwrapFunctor
foldMap f = F.foldMap f . unwrapFunctor
foldr f z = F.foldr f z . unwrapFunctor
foldl f q = F.foldl f q . unwrapFunctor
foldr1 f = F.foldr1 f . unwrapFunctor
foldl1 f = F.foldl1 f . unwrapFunctor
#if MIN_VERSION_base(4,6,0)
foldr' f z = F.foldr' f z . unwrapFunctor
foldl' f q = F.foldl' f q . unwrapFunctor
#endif
#if MIN_VERSION_base(4,8,0)
toList = F.toList . unwrapFunctor
null = F.null . unwrapFunctor
length = F.length . unwrapFunctor
elem x = F.elem x . unwrapFunctor
maximum = F.maximum . unwrapFunctor
minimum = F.minimum . unwrapFunctor
sum = F.sum . unwrapFunctor
product = F.product . unwrapFunctor
#endif
#if MIN_VERSION_base(4,13,0)
foldMap' f = F.foldMap' f . unwrapFunctor
#endif
instance T.Traversable f => T.Traversable (WrappedFunctor f) where
traverse f = fmap WrapFunctor . T.traverse f . unwrapFunctor
sequenceA = fmap WrapFunctor . T.sequenceA . unwrapFunctor
mapM f = liftM WrapFunctor . T.mapM f . unwrapFunctor
sequence = liftM WrapFunctor . T.sequence . unwrapFunctor
-------------------------------------------------------------------------------
-- WrappedContravariant
-------------------------------------------------------------------------------
-- | Wrap a 'Contravariant' functor to be used as a member of 'Invariant'.
newtype WrappedContravariant f a = WrapContravariant { unwrapContravariant :: f a }
deriving (Eq, Ord, Read, Show)
instance Contravariant f => Invariant (WrappedContravariant f) where
invmap = invmapContravariant
instance Contravariant f => Contravariant (WrappedContravariant f) where
contramap f = WrapContravariant . contramap f . unwrapContravariant
x >$ WrapContravariant f = WrapContravariant (x >$ f)
instance Divisible f => Divisible (WrappedContravariant f) where
divide f (WrapContravariant l) (WrapContravariant r) =
WrapContravariant $ divide f l r
conquer = WrapContravariant conquer
instance Decidable f => Decidable (WrappedContravariant f) where
lose = WrapContravariant . lose
choose f (WrapContravariant l) (WrapContravariant r) =
WrapContravariant $ choose f l r
-------------------------------------------------------------------------------
-- The Invariant2 class
-------------------------------------------------------------------------------
-- | Any @* -> * -> *@ type parametric in both arguments permits an instance of
-- @Invariant2@.
--
-- Instances should satisfy the following laws:
--
-- > invmap2 id id id id = id
-- > invmap2 f2 f2' g2 g2' . invmap2 f1 f1' g1 g1' =
-- > invmap2 (f2 . f1) (f1' . f2') (g2 . g1) (g1' . g2')
class Invariant2 f where
invmap2 :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
-- | Every 'Bifunctor' is also an 'Invariant2' functor.
invmap2Bifunctor :: Bifunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Bifunctor f _ g _ = bimap f g
-- | Every 'Profunctor' is also an 'Invariant2' functor.
invmap2Profunctor :: Profunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Profunctor _ f' g _ = dimap f' g
-------------------------------------------------------------------------------
-- Invariant2 instances
-------------------------------------------------------------------------------
instance Invariant2 (->) where invmap2 = invmap2Profunctor
instance Invariant2 Either where invmap2 = invmap2Bifunctor
instance Invariant2 (,) where invmap2 f _ g _ ~(x, y) = (f x, g y)
instance Invariant2 ((,,) a) where invmap2 f _ g _ ~(a, x, y) = (a, f x, g y)
instance Invariant2 ((,,,) a b) where
invmap2 f _ g _ ~(a, b, x, y) = (a, b, f x, g y)
instance Invariant2 ((,,,,) a b c) where
invmap2 f _ g _ ~(a, b, c, x, y) = (a, b, c, f x, g y)
-- | from "Control.Applicative"
instance Invariant2 Const where invmap2 = invmap2Bifunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant2 (App.WrappedArrow arr) where
invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from "Control.Arrow"
instance Invariant m => Invariant2 (Kleisli m) where
invmap2 _ f' g g' (Kleisli m) = Kleisli $ invmap g g' . m . f'
-- | from "Data.Semigroup"
instance Invariant2 Arg where
invmap2 = invmap2Bifunctor
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant f, Invariant g) => Invariant2 (Biff p f g) where
invmap2 f f' g g' =
Biff . invmap2 (invmap f f') (invmap f' f) (invmap g g') (invmap g' g) . runBiff
-- | from the @bifunctors@ package
instance Invariant f => Invariant2 (Clown f) where
invmap2 f f' _ _ = Clown . invmap f f' . runClown
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant2 (Flip p) where
invmap2 f f' g g' = Flip . invmap2 g g' f f' . runFlip
-- | from the @bifunctors@ package
instance Invariant g => Invariant2 (Joker g) where
invmap2 _ _ g g' = Joker . invmap g g' . runJoker
-- | from the @bifunctors@ package
instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctor.Product f g) where
invmap2 f f' g g' (Bifunctor.Pair x y) =
Bifunctor.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Bifunctor.Sum p q) where
invmap2 f f' g g' (Bifunctor.L2 l) = Bifunctor.L2 (invmap2 f f' g g' l)
invmap2 f f' g g' (Bifunctor.R2 r) = Bifunctor.R2 (invmap2 f f' g g' r)
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Tannen f p) where
invmap2 f f' g g' =
Tannen . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runTannen
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant2 (WrappedBifunctor p) where
invmap2 = invmap2Bifunctor
-- | from the @comonad@ package
instance Invariant w => Invariant2 (Cokleisli w) where
invmap2 f f' g _ (Cokleisli w) = Cokleisli $ g . w . invmap f' f
-- | from the @contravariant@ package
instance Invariant2 Op where
invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Star f) where
invmap2 _ ba cd dc (Star afc) = Star $ invmap cd dc . afc . ba
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Costar f) where
invmap2 ab ba cd _ (Costar fbc) = Costar $ cd . fbc . invmap ba ab
-- | from the @profunctors@ package
instance Arrow arr => Invariant2 (Pro.WrappedArrow arr) where
invmap2 _ f' g _ (Pro.WrapArrow x) = Pro.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from the @profunctors@ package
instance Invariant2 (Forget r) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Cayley f p) where
invmap2 f f' g g' =
Cayley . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runCayley
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Closure p) where
invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p
-- | from the @profunctors@ package
instance Invariant2 (Environment p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Codensity p) where
invmap2 ac ca bd db (Codensity f) =
Codensity (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Procompose p q) where
invmap2 l l' r r' (Procompose f g) =
Procompose (invmap2 id id r r' f) (invmap2 l l' id id g)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Rift p q) where
invmap2 ac ca bd db (Rift f) = Rift (invmap2 ac ca id id . f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Ran p q) where
invmap2 ac ca bd db (Ran f) = Ran (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Tambara p) where
invmap2 f f' g g' (Tambara p) =
Tambara $ invmap2 (first f) (first f') (first g) (first g') p
-- | from the @profunctors@ package
instance Invariant2 (PastroSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeMapping p) where
invmap2 f f' g g' (CofreeMapping p) =
CofreeMapping (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeMapping p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeTraversing p) where
invmap2 f f' g g' (CofreeTraversing p) =
CofreeTraversing (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeTraversing p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Pastro p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Cotambara p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Copastro p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CopastroSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CotambaraSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (TambaraSum p) where
invmap2 f f' g g' (TambaraSum p) =
TambaraSum (invmap2 (first f) (first f') (first g) (first g') p)
-- | from the @profunctors@ package
instance Invariant2 (Yoneda p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Coyoneda p) where
invmap2 = invmap2Profunctor
-- | from the @tagged@ package
instance Invariant2 Tagged where
invmap2 = invmap2Bifunctor
-- | from the @transformers@ package
instance Invariant2 Constant where
invmap2 f _ _ _ (Constant x) = Constant (f x)
-------------------------------------------------------------------------------
-- WrappedProfunctor
-------------------------------------------------------------------------------
-- | Wrap a 'Profunctor' to be used as a member of 'Invariant2'.
newtype WrappedProfunctor p a b = WrapProfunctor { unwrapProfunctor :: p a b }
deriving (Eq, Ord, Read, Show)
instance Profunctor p => Invariant2 (WrappedProfunctor p) where
invmap2 = invmap2Profunctor
instance Profunctor p => Invariant (WrappedProfunctor p a) where
invmap = invmap2 id id
instance Profunctor p => Profunctor (WrappedProfunctor p) where
dimap f g = WrapProfunctor . dimap f g . unwrapProfunctor
lmap f = WrapProfunctor . lmap f . unwrapProfunctor
rmap g = WrapProfunctor . rmap g . unwrapProfunctor
WrapProfunctor x .# f = WrapProfunctor (x .# f)
g #. WrapProfunctor x = WrapProfunctor (g #. x)
instance Cat.Category p => Cat.Category (WrappedProfunctor p) where
id = WrapProfunctor Cat.id
WrapProfunctor p1 . WrapProfunctor p2 = WrapProfunctor (p1 Cat.. p2)
instance Arrow p => Arrow (WrappedProfunctor p) where
arr = WrapProfunctor . arr
first = WrapProfunctor . Arr.first . unwrapProfunctor
second = WrapProfunctor . Arr.second . unwrapProfunctor
WrapProfunctor p1 *** WrapProfunctor p2 = WrapProfunctor (p1 *** p2)
WrapProfunctor p1 &&& WrapProfunctor p2 = WrapProfunctor (p1 &&& p2)
instance ArrowZero p => ArrowZero (WrappedProfunctor p) where
zeroArrow = WrapProfunctor zeroArrow
instance ArrowPlus p => ArrowPlus (WrappedProfunctor p) where
WrapProfunctor p1 <+> WrapProfunctor p2 = WrapProfunctor (p1 <+> p2)
instance ArrowChoice p => ArrowChoice (WrappedProfunctor p) where
left = WrapProfunctor . left . unwrapProfunctor
right = WrapProfunctor . right . unwrapProfunctor
WrapProfunctor p1 +++ WrapProfunctor p2 = WrapProfunctor (p1 +++ p2)
WrapProfunctor p1 ||| WrapProfunctor p2 = WrapProfunctor (p1 ||| p2)
instance ArrowLoop p => ArrowLoop (WrappedProfunctor p) where
loop = WrapProfunctor . loop . unwrapProfunctor
instance Strong p => Strong (WrappedProfunctor p) where
first' = WrapProfunctor . first' . unwrapProfunctor
second' = WrapProfunctor . second' . unwrapProfunctor
instance Choice p => Choice (WrappedProfunctor p) where
left' = WrapProfunctor . left' . unwrapProfunctor
right' = WrapProfunctor . right' . unwrapProfunctor
instance Costrong p => Costrong (WrappedProfunctor p) where
unfirst = WrapProfunctor . unfirst . unwrapProfunctor
unsecond = WrapProfunctor . unsecond . unwrapProfunctor
instance Cochoice p => Cochoice (WrappedProfunctor p) where
unleft = WrapProfunctor . unleft . unwrapProfunctor
unright = WrapProfunctor . unright . unwrapProfunctor
instance Closed p => Closed (WrappedProfunctor p) where
closed = WrapProfunctor . closed . unwrapProfunctor
instance Traversing p => Traversing (WrappedProfunctor p) where
traverse' = WrapProfunctor . traverse' . unwrapProfunctor
wander f = WrapProfunctor . wander f . unwrapProfunctor
instance Mapping p => Mapping (WrappedProfunctor p) where
map' = WrapProfunctor . map' . unwrapProfunctor
instance ProfunctorFunctor WrappedProfunctor where
promap f = WrapProfunctor . f . unwrapProfunctor
instance ProfunctorMonad WrappedProfunctor where
proreturn = WrapProfunctor
projoin = unwrapProfunctor
instance ProfunctorComonad WrappedProfunctor where
proextract = unwrapProfunctor
produplicate = WrapProfunctor
#if GHC_GENERICS_OK
-------------------------------------------------------------------------------
-- GHC Generics
-------------------------------------------------------------------------------
-- | from "GHC.Generics"
instance Invariant V1 where
-- NSF 25 July 2015: I'd prefer an -XEmptyCase, but Haskell98.
invmap _ _ x = x `seq` error "Invariant V1"
-- | from "GHC.Generics"
instance Invariant U1 where invmap _ _ _ = U1
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:+:) l r) where
invmap f g (L1 l) = L1 $ invmap f g l
invmap f g (R1 r) = R1 $ invmap f g r
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:*:) l r) where
invmap f g ~(l :*: r) = invmap f g l :*: invmap f g r
-- | from "GHC.Generics"
instance Invariant (K1 i c) where invmap _ _ (K1 c) = K1 c
-- | from "GHC.Generics"
instance Invariant2 (K1 i) where invmap2 f _ _ _ (K1 c) = K1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (M1 i t f) where invmap f g (M1 fp) = M1 $ invmap f g fp
-- | from "GHC.Generics"
instance Invariant Par1 where invmap f _ (Par1 c) = Par1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (Rec1 f) where invmap f g (Rec1 fp) = Rec1 $ invmap f g fp
-- | from "GHC.Generics"
instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where
invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp
# if __GLASGOW_HASKELL__ >= 800
-- | from "GHC.Generics"
instance Invariant UAddr where
invmap _ _ (UAddr a) = UAddr a
-- | from "GHC.Generics"
instance Invariant UChar where
invmap _ _ (UChar c) = UChar c
-- | from "GHC.Generics"
instance Invariant UDouble where
invmap _ _ (UDouble d) = UDouble d
-- | from "GHC.Generics"
instance Invariant UFloat where
invmap _ _ (UFloat f) = UFloat f
-- | from "GHC.Generics"
instance Invariant UInt where
invmap _ _ (UInt i) = UInt i
-- | from "GHC.Generics"
instance Invariant UWord where
invmap _ _ (UWord w) = UWord w
# endif
{- $ghcgenerics
With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC
generics like so:
@
{-# LANGUAGE DeriveGeneric, FlexibleContexts #-}
import Data.Functor.Invariant
import GHC.Generics
data T f a = T (f a) deriving Generic1
instance Invariant f => 'Invariant' (T f)
@
Be aware that generic 'Invariant' instances cannot be derived for data types
that have function arguments in which the last type parameter appears in a
position other than the result type (e.g., @data Fun a = Fun (a -> a)@). For
these, you can derive them using the "Data.Functor.Invariant.TH" module.
-}
-- | A generic implementation of 'invmap'.
genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
genericInvmap f g = to1 . invmap f g . from1
#endif
-------------------------------------------------------------------------------
-- Wrappers
-------------------------------------------------------------------------------
-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantProfunctor p a = InvariantProfunctor (p a a)
instance Profunctor p => Invariant (InvariantProfunctor p) where
invmap fn1 fn2 (InvariantProfunctor f) = InvariantProfunctor (invmapProfunctor fn1 fn2 f)
-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantArrow c a = InvariantArrow (c a a)
instance Arrow c => Invariant (InvariantArrow c) where
invmap fn1 fn2 (InvariantArrow arrow) = InvariantArrow (invmapArrow fn1 fn2 arrow)
invariant-0.6.3/src/Data/Functor/Invariant/ 0000755 0000000 0000000 00000000000 07346545000 016717 5 ustar 00 0000000 0000000 invariant-0.6.3/src/Data/Functor/Invariant/TH.hs 0000644 0000000 0000000 00000110114 07346545000 017564 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-|
Module: Data.Functor.Invariant.TH
Copyright: (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
Functions to mechanically derive 'Data.Functor.Invariant.Invariant'
or 'Data.Functor.Invariant.Invariant2' instances,
or to splice 'Data.Functor.Invariant.invmap' or
'Data.Functor.Invariant.invmap2' into Haskell source code. You need to enable
the @TemplateHaskell@ language extension in order to use this module.
-}
module Data.Functor.Invariant.TH (
-- * @deriveInvariant(2)@
-- $deriveInvariant
deriveInvariant
, deriveInvariantOptions
-- $deriveInvariant2
, deriveInvariant2
, deriveInvariant2Options
-- * @makeInvmap(2)@
-- $make
, makeInvmap
, makeInvmapOptions
, makeInvmap2
, makeInvmap2Options
-- * 'Options'
, Options(..)
, defaultOptions
) where
import Control.Monad (unless, when)
import Data.Functor.Invariant.TH.Internal
import qualified Data.List as List
import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)
import Data.Maybe
import Language.Haskell.TH.Datatype as Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
-------------------------------------------------------------------------------
-- User-facing API
-------------------------------------------------------------------------------
-- | Options that further configure how the functions in
-- "Data.Functor.Invariant.TH" should behave.
newtype Options = Options
{ emptyCaseBehavior :: Bool
-- ^ If 'True', derived instances for empty data types (i.e., ones with
-- no data constructors) will use the @EmptyCase@ language extension.
-- If 'False', derived instances will simply use 'seq' instead.
-- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
-- available in 7.8 or later.)
} deriving (Eq, Ord, Read, Show)
-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to
-- prevent users from having to enable that extension at use sites.)
defaultOptions :: Options
defaultOptions = Options { emptyCaseBehavior = False }
{- $deriveInvariant
'deriveInvariant' automatically generates an 'Data.Functor.Invariant.Invariant'
instance declaration for a data type, newtype, or data family instance that has
at least one type variable. This emulates what would (hypothetically) happen
if you could attach a @deriving 'Data.Functor.Invariant.Invariant'@ clause to
the end of a data declaration. Examples:
@
{-# LANGUAGE TemplateHaskell #-}
import Data.Functor.Invariant.TH
data Pair a = Pair a a
$('deriveInvariant' ''Pair) -- instance Invariant Pair where ...
newtype Alt f a = Alt (f a)
$('deriveInvariant' ''Alt) -- instance Invariant f => Invariant (Alt f) where ...
@
If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
'deriveInvariant' can also be used to derive 'Data.Functor.Invariant.Invariant' instances for data family
instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of
a data or newtype instance constructor to 'deriveInvariant'. Note that the generated
code may require the @-XFlexibleInstances@ extension. Some examples:
@
{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}
import Data.Functor.Invariant.TH
class AssocClass a b where
data AssocData a b
instance AssocClass Int b where
data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b Int
$('deriveInvariant' 'AssocDataInt1) -- instance Invariant (AssocData Int) where ...
-- Alternatively, one could use $(deriveInvariant 'AssocDataInt2)
data family DataFam a b
newtype instance DataFam () b = DataFamB b
$('deriveInvariant' 'DataFamB) -- instance Invariant (DataFam ())
@
Note that there are some limitations:
* The 'Name' argument to 'deriveInvariant' must not be a type synonym.
* With 'deriveInvariant', the argument's last type variable must be of kind @*@.
For other ones, type variables of kind @* -> *@ are assumed to require an
'Data.Functor.Invariant.Invariant' context. For more complicated scenarios,
use 'makeInvmap'.
* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
extensions, a constraint cannot mention the last type variable. For example,
@data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived
'Data.Functor.Invariant.Invariant' instance.
* If the last type variable is used within a data field of a constructor, it must only
be used in the last argument of the data type constructor. For example, @data Legal a
= Legal (Either Int a)@ can have a derived 'Data.Functor.Invariant.Invariant' instance,
but @data Illegal a = Illegal (Either a a)@ cannot.
* Data family instances must be able to eta-reduce the last type variable. In other
words, if you have a instance of the form:
@
data family Family a1 ... an t
data instance Family e1 ... e2 v = ...
@
Then the following conditions must hold:
1. @v@ must be a type variable.
2. @v@ must not be mentioned in any of @e1@, ..., @e2@.
-}
-- | Generates an 'Data.Functor.Invariant.Invariant' instance declaration for the given
-- data type or data family instance.
deriveInvariant :: Name -> Q [Dec]
deriveInvariant = deriveInvariantOptions defaultOptions
-- | Like 'deriveInvariant', but takes an 'Options' argument.
deriveInvariantOptions :: Options -> Name -> Q [Dec]
deriveInvariantOptions = deriveInvariantClass Invariant
{- $deriveInvariant2
'deriveInvariant2' automatically generates an
'Data.Functor.Invariant.Invariant2' instance declaration for a data type,
newtype, or data family instance that has at least two type variables. This
emulates what would (hypothetically) happen if you could attach a @deriving
'Data.Functor.Invariant.Invariant2'@ clause to the end of a data declaration.
Examples:
@
{-# LANGUAGE TemplateHaskell #-}
import Data.Functor.Invariant.TH
data OneOrNone a b = OneL a | OneR b | None
$('deriveInvariant2' ''OneOrNone) -- instance Invariant2 OneOrNone where ...
newtype Alt2 f a b = Alt2 (f a b)
$('deriveInvariant2' ''Alt2) -- instance Invariant2 f => Invariant2 (Alt2 f) where ...
@
The same restrictions that apply to 'deriveInvariant' also apply to 'deriveInvariant2',
with some caveats:
* With 'deriveInvariant2', the last type variables must both be of kind @*@. For other
ones, type variables of kind @* -> *@ are assumed to require an 'Data.Functor.Invariant.Invariant'
constraint, and type variables of kind @* -> * -> *@ are assumed to require an
'Data.Functor.Invariant.Invariant2' constraint. For more complicated scenarios, use 'makeInvmap2'.
* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
extensions, a constraint cannot mention either of the last two type variables. For
example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
have a derived 'Data.Functor.Invariant.Invariant2' instance.
* If either of the last two type variables is used within a data field of a constructor,
it must only be used in the last two arguments of the data type constructor. For
example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived
'Data.Functor.Invariant.Invariant2' instance, but
@data Illegal a b = Illegal (a, b, a, b)@ cannot.
* Data family instances must be able to eta-reduce the last two type variables. In other
words, if you have a instance of the form:
@
data family Family a1 ... an t1 t2
data instance Family e1 ... e2 v1 v2 = ...
@
Then the following conditions must hold:
1. @v1@ and @v2@ must be distinct type variables.
2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.
-}
-- | Generates an 'Data.Functor.Invariant.Invariant2' instance declaration for
-- the given data type or data family instance.
deriveInvariant2 :: Name -> Q [Dec]
deriveInvariant2 = deriveInvariant2Options defaultOptions
-- | Like 'deriveInvariant2', but takes an 'Options' argument.
deriveInvariant2Options :: Options -> Name -> Q [Dec]
deriveInvariant2Options = deriveInvariantClass Invariant2
{- $make
There may be scenarios in which you want to @invmap@ over an arbitrary data
type or data family instance without having to make the type an instance of
'Data.Functor.Invariant.Invariant'. For these cases, this module provides
several functions (all prefixed with @make-@) that splice the appropriate
lambda expression into your source code. Example:
This is particularly useful for creating instances for sophisticated data
types. For example, 'deriveInvariant' cannot infer the correct type context for
@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
@* -> * -> * -> *@. However, it is still possible to create an
'Data.Functor.Invariant.Invariant' instance for @HigherKinded@ without too much
trouble using 'makeInvmap':
@
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
import Data.Functor.Invariant
import Data.Functor.Invariant.TH
newtype HigherKinded f a b c = HigherKinded (f a b c)
instance Invariant (f a b) => Invariant (HigherKinded f a b) where
invmap = $(makeInvmap ''HigherKinded)
@
-}
-- | Generates a lambda expression which behaves like
-- 'Data.Functor.Invariant.invmap' (without requiring an
-- 'Data.Functor.Invariant.Invariant' instance).
makeInvmap :: Name -> Q Exp
makeInvmap = makeInvmapOptions defaultOptions
-- | Like 'makeInvmap', but takes an 'Options' argument.
makeInvmapOptions :: Options -> Name -> Q Exp
makeInvmapOptions = makeInvmapClass Invariant
-- | Generates a lambda expression which behaves like
-- 'Data.Functor.Invariant.invmap2' (without requiring an
-- 'Data.Functor.Invariant.Invariant2' instance).
makeInvmap2 :: Name -> Q Exp
makeInvmap2 = makeInvmap2Options defaultOptions
-- | Like 'makeInvmap2', but takes an 'Options' argument.
makeInvmap2Options :: Options -> Name -> Q Exp
makeInvmap2Options = makeInvmapClass Invariant2
-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------
-- | Derive an Invariant(2) instance declaration (depending on the InvariantClass
-- argument's value).
deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
deriveInvariantClass iClass opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTys
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance iClass parentName ctxt instTys variant
(:[]) `fmap` instanceD (return instanceCxt)
(return instanceType)
(invmapDecs iClass opts parentName instTys cons)
-- | Generates a declaration defining the primary function corresponding to a
-- particular class (invmap for Invariant and invmap2 for Invariant2).
invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> [Q Dec]
invmapDecs iClass opts parentName instTys cons =
[ funD (invmapName iClass)
[ clause []
(normalB $ makeInvmapForCons iClass opts parentName instTys cons)
[]
]
]
-- | Generates a lambda expression which behaves like invmap (for Invariant),
-- or invmap2 (for Invariant2).
makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
makeInvmapClass iClass opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTys
, datatypeVariant = variant
, datatypeCons = cons
} ->
-- We force buildTypeInstance here since it performs some checks for whether
-- or not the provided datatype can actually have invmap/invmap2
-- implemented for it, and produces errors if it can't.
buildTypeInstance iClass parentName ctxt instTys variant
>> makeInvmapForCons iClass opts parentName instTys cons
-- | Generates a lambda expression for invmap(2) for the given constructors.
-- All constructors must be from the same type.
makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
-> Q Exp
makeInvmapForCons iClass opts _parentName instTys cons = do
value <- newName "value"
covMaps <- newNameList "covMap" numNbs
contraMaps <- newNameList "contraMap" numNbs
let mapFuns = zip covMaps contraMaps
lastTyVars = map varTToName $ drop (length instTys - numNbs) instTys
tvMap = Map.fromList $ zip lastTyVars mapFuns
argNames = concat (List.transpose [covMaps, contraMaps]) ++ [value]
lamE (map varP argNames)
. appsE
$ [ varE $ invmapConstName iClass
, makeFun value tvMap
] ++ map varE argNames
where
numNbs :: Int
numNbs = fromEnum iClass
makeFun :: Name -> TyVarMap -> Q Exp
makeFun value tvMap = do
#if MIN_VERSION_template_haskell(2,9,0)
roles <- reifyRoles _parentName
let rroles = roles
#endif
case () of
_
#if MIN_VERSION_template_haskell(2,9,0)
| (length rroles >= numNbs) &&
(all (== PhantomR) (drop (length rroles - numNbs) rroles))
-> varE coerceValName `appE` varE value
#endif
| null cons && emptyCaseBehavior opts && ghc7'8OrLater
-> caseE (varE value) []
| null cons
-> appE (varE seqValName) (varE value) `appE`
appE (varE errorValName)
(stringE $ "Void " ++ nameBase (invmapName iClass))
| otherwise
-> caseE (varE value)
(map (makeInvmapForCon iClass tvMap) cons)
ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater = True
#else
ghc7'8OrLater = False
#endif
-- | Generates a match for invmap(2) for a single constructor.
makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match
makeInvmapForCon iClass tvMap
con@(ConstructorInfo { constructorName = conName
, constructorContext = ctxt }) = do
when (any (`predMentionsName` Map.keys tvMap) ctxt
|| Map.size tvMap < fromEnum iClass) $
existentialContextError conName
parts <- foldDataConArgs iClass tvMap ft_invmap con
match_for_con conName parts
where
ft_invmap :: FFoldType (Exp -> Q Exp)
ft_invmap = FT { ft_triv = return
, ft_var = \v x -> return $ VarE (fst (tvMap Map.! v)) `AppE` x
, ft_co_var = \v x -> return $ VarE (snd (tvMap Map.! v)) `AppE` x
, ft_fun = \g h x -> mkSimpleLam $ \b -> do
gg <- g b
h $ x `AppE` gg
, ft_tup = mkSimpleTupleCase match_for_con
, ft_ty_app = \contravariant argGs x -> do
let inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
inspect (argTy, g, h)
-- If the argument type is a bare occurrence of one
-- of the data type's last type variables, then we
-- can generate more efficient code.
-- This was inspired by GHC#17880.
| Just argVar <- varTToName_maybe argTy
, Just (covMap, contraMap) <- Map.lookup argVar tvMap
= map (return . VarE) $
if contravariant
then [contraMap, covMap]
else [covMap, contraMap]
| otherwise
= [mkSimpleLam g, mkSimpleLam h]
appsE $ varE (invmapName (toEnum (length argGs)))
: concatMap inspect argGs
++ [return x]
, ft_forall = \_ g x -> g x
, ft_bad_app = \_ -> outOfPlaceTyVarError conName
}
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
match_for_con = mkSimpleConMatch $ \conName' xs ->
appsE (conE conName':xs) -- Con x1 x2 ..
-------------------------------------------------------------------------------
-- Template Haskell reifying and AST manipulation
-------------------------------------------------------------------------------
-- For the given Types, generate an instance context and head. Coming up with
-- the instance type isn't as simple as dropping the last types, as you need to
-- be wary of kinds being instantiated with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: InvariantClass
-- ^ Invariant or Invariant2
-> Name
-- ^ The type constructor or data family name
-> Cxt
-- ^ The datatype context
-> [Type]
-- ^ The types to instantiate the instance with
-> DatatypeVariant
-- ^ Are we dealing with a data family instance or not
-> Q (Cxt, Type)
buildTypeInstance iClass tyConName dataCxt varTysOrig variant = do
-- Make sure to expand through type/kind synonyms! Otherwise, the
-- eta-reduction check might get tripped up over type variables in a
-- synonym that are actually dropped.
-- (See GHC Trac #11416 for a scenario where this actually happened.)
varTysExp <- mapM resolveTypeSynonyms varTysOrig
let remainingLength :: Int
remainingLength = length varTysOrig - fromEnum iClass
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
-- Check there are enough types to drop and that all of them are either of
-- kind * or kind k (for some kind variable k). If not, throw an error.
when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
derivingKindError iClass tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames = catKindVarNames droppedStarKindStati
-- Substitute kind * for any dropped kind variables
varTysExpSubst :: [Type]
varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(remainingTysExpSubst, droppedTysExpSubst) =
splitAt remainingLength varTysExpSubst
-- All of the type variables mentioned in the dropped types
-- (post-synonym expansion)
droppedTyVarNames :: [Name]
droppedTyVarNames = freeVariables droppedTysExpSubst
-- If any of the dropped types were polykinded, ensure that there are of kind *
-- after substituting * for the dropped kind variables. If not, throw an error.
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError iClass tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
-- Derive instance constraints (and any kind variables which are specialized
-- to * in those constraints)
(preds, kvNames) = unzip $ map (deriveConstraint iClass) remainingTysExpSubst
kvNames' = concat kvNames
-- Substitute the kind variables specialized in the constraints with *
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
map (substNamesWithKindStar kvNames') remainingTysExpSubst
-- We now substitute all of the specialized-to-* kind variable names with
-- *, but in the original types, not the synonym-expanded types. The reason
-- we do this is a superficial one: we want the derived instance to resemble
-- the datatype written in source code as closely as possible. For example,
-- for the following data family instance:
--
-- data family Fam a
-- newtype instance Fam String = Fam String
--
-- We'd want to generate the instance:
--
-- instance C (Fam String)
--
-- Not:
--
-- instance C (Fam [Char])
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
map (substNamesWithKindStar (List.union droppedKindVarNames kvNames'))
$ take remainingLength varTysOrig
isDataFamily <-
case variant of
Datatype -> return False
Newtype -> return False
DataInstance -> return True
NewtypeInstance -> return True
#if MIN_VERSION_th_abstraction(0,5,0)
Datatype.TypeData -> typeDataError tyConName
#endif
let remainingTysOrigSubst' :: [Type]
-- See Note [Kind signatures in derived instances] for an explanation
-- of the isDataFamily check.
remainingTysOrigSubst' =
if isDataFamily
then remainingTysOrigSubst
else map unSigT remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT $ invariantClassName iClass)
$ applyTyCon tyConName remainingTysOrigSubst'
-- If the datatype context mentions any of the dropped type variables,
-- we can't derive an instance, so throw an error.
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
-- Also ensure the dropped types can be safely eta-reduced. Otherwise,
-- throw an error.
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: InvariantClass -> Type -> (Maybe Pred, [Name])
deriveConstraint iClass t
| not (isTyVar t) = (Nothing, [])
| otherwise = case hasKindVarChain 1 t of
Just ns | iClass >= Invariant
-> (Just (applyClass invariantTypeName tName), ns)
_ -> case hasKindVarChain 2 t of
Just ns | iClass == Invariant2
-> (Just (applyClass invariant2TypeName tName), ns)
_ -> (Nothing, [])
where
tName :: Name
tName = varTToName t
{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is possible to put explicit kind signatures into the derived instances, e.g.,
instance C a => C (Data (f :: * -> *)) where ...
But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since our type inferencer is pretty
unsophisticated - see Note [Type inference in derived instances]), then GHC will
flat-out reject the instance, which is quite unfortunate.
Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.
Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,
data family Fam (a :: k)
data instance Fam (a :: * -> *)
data instance Fam (a :: *)
If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the make- functions.
Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:
1. If one of the last type parameters is polykinded, then its kind will be
specialized to * in the derived instance. We note what kind variable the type
parameter had and substitute it with * in the other types as well. For example,
imagine you had
data Data (a :: k) (b :: k) (c :: k)
Then you'd want to derived instance to be:
instance C (Data (a :: *))
Not:
instance C (Data (a :: k))
2. We naïvely come up with instance constraints using the following criteria:
(i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
variables), then generate an Invariant n constraint, and if k1/k2 are kind
variables, then substitute k1/k2 with * elsewhere in the types. We must
consider the case where they are kind variables because you might have a
scenario like this:
newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)
= Compose (f (g a b))
Which would have a derived Invariant2 instance of:
instance (Invariant f, Invariant2 g) => Invariant2 (Compose f g) where ...
(ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
* or kind variables), then generate a Invariant2 n constraint and perform
kind substitution as in the other case.
-}
-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------
-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: InvariantClass -> Name -> Q a
derivingKindError iClass tyConName = fail
. showString "Cannot derive well-kinded instance of form ‘"
. showString className
. showChar ' '
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass "
. showString className
. showString " expects an argument of kind "
. showString (pprint . createKindChain $ fromEnum iClass)
$ ""
where
className :: String
className = nameBase $ invariantClassName iClass
-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> Q a
datatypeContextError dataName instanceType = fail
. showString "Can't make a derived instance of ‘"
. showString (pprint instanceType)
. showString "‘:\n\tData type ‘"
. showString (nameBase dataName)
. showString "‘ must not have a class context involving the last type argument(s)"
$ ""
-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> Q a
existentialContextError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must be truly polymorphic in the last argument(s) of the data type"
$ ""
-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: Name -> Q a
outOfPlaceTyVarError conName = fail
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must only use its last two type variable(s) within"
. showString " the last two argument(s) of a data type"
$ ""
-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError instanceType = fail $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
#if MIN_VERSION_th_abstraction(0,5,0)
-- | We cannot implement class methods at the term level for @type data@
-- declarations, which only exist at the type level.
typeDataError :: Name -> Q a
typeDataError dataName = fail
. showString "Cannot derive instance for ‘"
. showString (nameBase dataName)
. showString "‘, which is a ‘type data‘ declaration"
$ ""
#endif
-------------------------------------------------------------------------------
-- Generic traversal for functor-like deriving
-------------------------------------------------------------------------------
-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.
data FFoldType a -- Describes how to fold over a Type in a functor like way
= FT { ft_triv :: a
-- ^ Does not contain variables
, ft_var :: Name -> a
-- ^ A bare variable
, ft_co_var :: Name -> a
-- ^ A bare variable, contravariantly
, ft_fun :: a -> a -> a
-- ^ Function type
, ft_tup :: TupleSort -> [a] -> a
-- ^ Tuple type. The [a] is the result of folding over the
-- arguments of the tuple.
, ft_ty_app :: Bool -> [(Type, a, a)] -> a
-- ^ Type app, variables only in last argument. The [(Type, a, a)]
-- represents the last argument types. That is, they form the
-- argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.
--
-- The Bool is True if the Type is in a surrounding context that is
-- contravariant, and False if the surrounding context is covariant.
-- The two @a@ fields in [(Type, a, a)] represent the results of
-- folding over the Type in a covariant and contravariant manner,
-- respectively.
, ft_bad_app :: a
-- ^ Type app, variable other than in last arguments
, ft_forall :: [TyVarBndrSpec] -> a -> a
-- ^ Forall type
}
-- Note that in GHC, this function is pure. It must be monadic here since we:
--
-- (1) Expand type synonyms
-- (2) Detect type family applications
--
-- Which require reification in Template Haskell, but are pure in Core.
functorLikeTraverse :: InvariantClass -- ^ Invariant or Invariant2
-> TyVarMap -- ^ Variables to look for
-> FFoldType a -- ^ How to fold
-> Type -- ^ Type to process
-> Q a
functorLikeTraverse iClass tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar
, ft_co_var = caseCoVar, ft_fun = caseFun
, ft_tup = caseTuple, ft_ty_app = caseTyApp
, ft_bad_app = caseWrongArg, ft_forall = caseForAll })
ty
= do ty' <- resolveTypeSynonyms ty
(res, _) <- go False ty'
return res
where
{-
go :: Bool -- Covariant or contravariant context
-> Type
-> Q (a, Bool) -- (result of type a, does type contain var)
-}
go co t@AppT{}
| (ArrowT, [funArg, funRes]) <- unapplyTy t
= do (funArgR, funArgC) <- go (not co) funArg
(funResR, funResC) <- go co funRes
if funArgC || funResC
then return (caseFun funArgR funResR, True)
else trivial
go co t@AppT{} = do
let (f, args) = unapplyTy t
(_, fc) <- go co f
(xrs, xcs) <- fmap unzip $ mapM (go co) args
(contraXrs, _) <- fmap unzip $ mapM (go (not co)) args
let numLastArgs, numFirstArgs :: Int
numLastArgs = min (fromEnum iClass) (length args)
numFirstArgs = length args - numLastArgs
-- tuple :: TupleSort -> Q (a, Bool)
tuple tupSort = return (caseTuple tupSort xrs, True)
-- wrongArg :: Q (a, Bool)
wrongArg = return (caseWrongArg, True)
case () of
_ | not (or xcs)
-> trivial -- Variable does not occur
-- At this point we know that xrs, xcs is not empty,
-- and at least one xr is True
| TupleT len <- f
-> tuple $ Boxed len
#if MIN_VERSION_template_haskell(2,6,0)
| UnboxedTupleT len <- f
-> tuple $ Unboxed len
#endif
| fc || or (take numFirstArgs xcs)
-> wrongArg -- T (..var..) ty_1 ... ty_n
| otherwise -- T (..no var..) ty_1 ... ty_n
-> do itf <- isInTypeFamilyApp tyVarNames f args
if itf -- We can't decompose type families, so
-- error if we encounter one here.
then wrongArg
else return ( caseTyApp co $ drop numFirstArgs
$ zip3 args xrs contraXrs
, True )
go co (SigT t k) = do
(_, kc) <- go_kind co k
if kc
then return (caseWrongArg, True)
else go co t
go co (VarT v)
| Map.member v tvMap
= return (if co then caseCoVar v else caseVar v, True)
| otherwise
= trivial
go co (ForallT tvbs _ t) = do
(tr, tc) <- go co t
let tvbNames = map tvName tvbs
if not tc || any (`elem` tvbNames) tyVarNames
then trivial
else return (caseForAll tvbs tr, True)
go _ _ = trivial
{-
go_kind :: Bool
-> Kind
-> Q (a, Bool)
-}
#if MIN_VERSION_template_haskell(2,9,0)
go_kind = go
#else
go_kind _ _ = trivial
#endif
-- trivial :: Q (a, Bool)
trivial = return (caseTrivial, False)
tyVarNames :: [Name]
tyVarNames = Map.keys tvMap
-- Fold over the arguments of a data constructor in a Functor-like way.
foldDataConArgs :: InvariantClass -> TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
foldDataConArgs iClass tvMap ft con = do
fieldTys <- mapM resolveTypeSynonyms $ constructorFields con
mapM foldArg fieldTys
where
-- foldArg :: Type -> Q a
foldArg = functorLikeTraverse iClass tvMap ft
-- Make a 'LamE' using a fresh variable.
mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
mkSimpleLam lam = do
n <- newName "n"
lamE [varP n] (lam (VarE n))
-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
-- @mkSimpleConMatch fold conName insides@ produces a match clause in
-- which the LHS pattern-matches on @extraPats@, followed by a match on the
-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over
-- @conName@ and its arguments, applying an expression (from @insides@) to each
-- of the respective arguments of @conName@.
mkSimpleConMatch :: (Name -> [a] -> Q Exp)
-> Name
-> [Exp -> a]
-> Q Match
mkSimpleConMatch fold conName insides = do
varsNeeded <- newNameList "_arg" $ length insides
let pat = ConP conName
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
(map VarP varsNeeded)
rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)
return $ Match pat (NormalB rhs) []
-- Indicates whether a tuple is boxed or unboxed, as well as its number of
-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)
-- corresponds to @Unboxed 3@.
data TupleSort
= Boxed Int
#if MIN_VERSION_template_haskell(2,6,0)
| Unboxed Int
#endif
-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
mkSimpleTupleCase :: (Name -> [a] -> Q Match)
-> TupleSort -> [a] -> Exp -> Q Exp
mkSimpleTupleCase matchForCon tupSort insides x = do
let tupDataName = case tupSort of
Boxed len -> tupleDataName len
#if MIN_VERSION_template_haskell(2,6,0)
Unboxed len -> unboxedTupleDataName len
#endif
m <- matchForCon tupDataName insides
return $ CaseE x [m]
invariant-0.6.3/src/Data/Functor/Invariant/TH/ 0000755 0000000 0000000 00000000000 07346545000 017232 5 ustar 00 0000000 0000000 invariant-0.6.3/src/Data/Functor/Invariant/TH/Internal.hs 0000644 0000000 0000000 00000036133 07346545000 021350 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#endif
{-|
Module: Data.Functor.Invariant.TH.Internal
Copyright: (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
Template Haskell-related utilities.
-}
module Data.Functor.Invariant.TH.Internal where
import Data.Foldable (foldr')
import Data.Functor.Invariant () -- To import the instances
import qualified Data.List as List
import qualified Data.Map as Map (singleton)
import Data.Map (Map)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import Data.Set (Set)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
#if __GLASGOW_HASKELL__ >= 800
import Data.Coerce (coerce)
import Data.Functor.Invariant (Invariant(..), Invariant2(..))
#else
# ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_invariant (version)
# endif
#endif
-------------------------------------------------------------------------------
-- Expanding type synonyms
-------------------------------------------------------------------------------
applySubstitutionKind :: Map Name Kind -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
applySubstitutionKind = applySubstitution
#else
applySubstitutionKind _ t = t
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind n k = applySubstitutionKind (Map.singleton n k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns
-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------
-- | A representation of which @Invariant@ is being used.
data InvariantClass = Invariant | Invariant2
deriving (Eq, Ord)
instance Enum InvariantClass where
fromEnum Invariant = 1
fromEnum Invariant2 = 2
toEnum 1 = Invariant
toEnum 2 = Invariant2
toEnum i = error $ "No Invariant class for number " ++ show i
invmapConstName :: InvariantClass -> Name
invmapConstName Invariant = invmapConstValName
invmapConstName Invariant2 = invmap2ConstValName
invariantClassName :: InvariantClass -> Name
invariantClassName Invariant = invariantTypeName
invariantClassName Invariant2 = invariant2TypeName
invmapName :: InvariantClass -> Name
invmapName Invariant = invmapValName
invmapName Invariant2 = invmap2ValName
-- | A type-restricted version of 'const'. This constrains the map functions
-- that are autogenerated by Template Haskell to be the correct type, even
-- if they aren't actually used in an invmap(2) expression. This is useful
-- in makeInvmap(2), since a map function might have its type inferred as
-- @a@ instead of @a -> b@ (which is clearly wrong).
invmapConst :: f b -> (a -> b) -> (b -> a) -> f a -> f b
invmapConst = const . const . const
{-# INLINE invmapConst #-}
invmap2Const :: f c d
-> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Const = const . const . const . const . const
{-# INLINE invmap2Const #-}
-------------------------------------------------------------------------------
-- StarKindStatus
-------------------------------------------------------------------------------
-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving Eq
-- | Does a Type have kind * or k (for some kind variable k)?
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar t
| hasKindStar t = KindStar
| otherwise = case t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k) -> IsKindVar k
#endif
_ -> NotKindStar
-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
-- Otherwise, returns 'Nothing'.
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n) = Just n
starKindStatusToName _ = Nothing
-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
-- the kind variables' Names out.
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = mapMaybe starKindStatusToName
-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------
-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar VarT{} = True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _ = False
-- Returns True is a kind is equal to *, or if it is a kind variable.
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar StarT = True
isStarOrVar VarT{} = True
#else
isStarOrVar StarK = True
#endif
isStarOrVar _ = False
-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain kindArrows t =
let uk = uncurryKind (tyKind t)
in if (length uk - 1 == kindArrows) && all isStarOrVar uk
then Just (freeVariables uk)
else Nothing
-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind (SigT _ k) = k
tyKind _ = starK
-- | A mapping of type variable Names to their map function Names. For example, in a
-- Invariant declaration, a TyVarMap might look like:
--
-- (a ~> (covA, contraA), b ~> (covB, contraB))
--
-- where a and b are the last two type variables of the datatype, and covA and covB
-- are the two map functions for a and b in covariant positions, and contraA and
-- contraB are the two map functions for a and b in contravariant positions.
type TyVarMap = Map Name (Name, Name)
fst3 :: (a, b, c) -> a
fst3 (a, _, _) = a
thd3 :: (a, b, c) -> c
thd3 (_, _, c) = c
-- Like 'lookup', but for lists of triples.
lookup2 :: Eq a => a -> [(a, b, c)] -> Maybe (b, c)
lookup2 _ [] = Nothing
lookup2 key ((x,y,z):xyzs)
| key == x = Just (y, z)
| otherwise = lookup2 key xyzs
-- | Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]
createKindChain :: Int -> Kind
createKindChain = go starK
where
go :: Kind -> Int -> Kind
go k 0 = k
go k n = n `seq` go (arrowKCompat starK k) (n - 1)
-- | Applies a typeclass constraint to a type.
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass con t = AppT (ConT con) (VarT t)
#else
applyClass con t = ClassP con [VarT t]
#endif
-- | Checks to see if the last types in a data family instance can be safely eta-
-- reduced (i.e., dropped), given the other types. This checks for three conditions:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce remaining dropped =
all isTyVar dropped
&& allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type
-- didn't have an Ord instance until template-haskell-2.10.0.0
&& not (any (`mentionsName` droppedNames) remaining)
where
droppedNames :: [Name]
droppedNames = map varTToName dropped
-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe (VarT n) = Just n
varTToName_maybe (SigT t _) = varTToName_maybe t
varTToName_maybe _ = Nothing
-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe
-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT (SigT t _) = t
unSigT t = t
-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar (VarT _) = True
isTyVar (SigT t _) = isTyVar t
isTyVar _ = False
-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp names tyFun tyArgs =
case tyFun of
ConT tcName -> go tcName
_ -> return False
where
go :: Name -> Q Bool
go tcName = do
info <- reify tcName
case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _
-> withinFirstArgs bndrs
#elif MIN_VERSION_template_haskell(2,7,0)
FamilyI (FamilyD TypeFam _ bndrs _) _
-> withinFirstArgs bndrs
#else
TyConI (FamilyD TypeFam _ bndrs _)
-> withinFirstArgs bndrs
#endif
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _
-> withinFirstArgs bndrs
#elif MIN_VERSION_template_haskell(2,9,0)
FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
-> withinFirstArgs bndrs
#endif
_ -> return False
where
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs bndrs =
let firstArgs = take (length bndrs) tyArgs
argFVs = freeVariables firstArgs
in return $ any (`elem` argFVs) names
-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct = allDistinct' Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' uniqs (x:xs)
| x `Set.member` uniqs = False
| otherwise = allDistinct' (Set.insert x uniqs) xs
allDistinct' _ _ = True
-- | Does the given type mention any of the Names in the list?
mentionsName :: Type -> [Name] -> Bool
mentionsName = go
where
go :: Type -> [Name] -> Bool
go (AppT t1 t2) names = go t1 names || go t2 names
go (SigT t _k) names = go t names
#if MIN_VERSION_template_haskell(2,8,0)
|| go _k names
#endif
go (VarT n) names = n `elem` names
go _ _ = False
-- | Does an instance predicate mention any of the Names in the list?
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName = mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif
-- | Construct a type via curried application.
applyTy :: Type -> [Type] -> Type
applyTy = List.foldl' AppT
-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon = applyTy . ConT
-- | Split an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would split to this:
--
-- @
-- [Either, Int, Char]
-- @
unapplyTy :: Type -> (Type, [Type])
unapplyTy ty = go ty ty []
where
go :: Type -> Type -> [Type] -> (Type, [Type])
go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)
go origTy (SigT ty' _) args = go origTy ty' args
#if MIN_VERSION_template_haskell(2,11,0)
go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args
go origTy (ParensT ty') args = go origTy ty' args
#endif
go origTy _ args = (origTy, args)
-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
-- forall a b. (a ~ b) => (a -> b) -> Char -> ()
-- @
--
-- would split to this:
--
-- @
-- (a ~ b, [a -> b, Char, ()])
-- @
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy (AppT (AppT ArrowT t1) t2) =
let (ctxt, tys) = uncurryTy t2
in (ctxt, t1:tys)
uncurryTy (SigT t _) = uncurryTy t
uncurryTy (ForallT _ ctxt t) =
let (ctxt', tys) = uncurryTy t
in (ctxt ++ ctxt', tys)
uncurryTy t = ([], [t])
-- | Like uncurryType, except on a kind level.
uncurryKind :: Kind -> [Kind]
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind = snd . uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2
uncurryKind k = [k]
#endif
-------------------------------------------------------------------------------
-- Quoted names
-------------------------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 800
-- With GHC 8.0 or later, we can simply use TemplateHaskellQuotes to quote each
-- name. Life is good.
invariantTypeName :: Name
invariantTypeName = ''Invariant
invariant2TypeName :: Name
invariant2TypeName = ''Invariant2
invmapValName :: Name
invmapValName = 'invmap
invmap2ValName :: Name
invmap2ValName = 'invmap2
invmapConstValName :: Name
invmapConstValName = 'invmapConst
invmap2ConstValName :: Name
invmap2ConstValName = 'invmap2Const
coerceValName :: Name
coerceValName = 'coerce
errorValName :: Name
errorValName = 'error
seqValName :: Name
seqValName = 'seq
#else
-- On pre-8.0 GHCs, we do not have access to the TemplateHaskellQuotes
-- extension, so we construct the Template Haskell names by hand.
-- By manually generating these names we avoid needing to use the
-- TemplateHaskell language extension when compiling the invariant library.
-- This allows the library to be used in stage1 cross-compilers.
invariantPackageKey :: String
# ifdef CURRENT_PACKAGE_KEY
invariantPackageKey = CURRENT_PACKAGE_KEY
# else
invariantPackageKey = "invariant-" ++ showVersion version
# endif
mkInvariantName_tc :: String -> String -> Name
mkInvariantName_tc = mkNameG_tc invariantPackageKey
mkInvariantName_v :: String -> String -> Name
mkInvariantName_v = mkNameG_v invariantPackageKey
invariantTypeName :: Name
invariantTypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant"
invariant2TypeName :: Name
invariant2TypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant2"
invmapValName :: Name
invmapValName = mkInvariantName_v "Data.Functor.Invariant" "invmap"
invmap2ValName :: Name
invmap2ValName = mkInvariantName_v "Data.Functor.Invariant" "invmap2"
invmapConstValName :: Name
invmapConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmapConst"
invmap2ConstValName :: Name
invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const"
coerceValName :: Name
coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"
errorValName :: Name
errorValName = mkNameG_v "base" "GHC.Err" "error"
seqValName :: Name
seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"
#endif
invariant-0.6.3/test/ 0000755 0000000 0000000 00000000000 07346545000 012663 5 ustar 00 0000000 0000000 invariant-0.6.3/test/InvariantSpec.hs 0000644 0000000 0000000 00000003071 07346545000 015766 0 ustar 00 0000000 0000000 module InvariantSpec (main, spec) where
import Data.Functor.Invariant
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck
main :: IO ()
main = hspec spec
data Proxy a = Proxy
-----
-- These test could probably be simplified by appealing to parametricity.
spec :: Spec
spec = do
describe "Invariant" . prop "satisfies the composition law" $
composition1 (Proxy :: Proxy Integer)
(Proxy :: Proxy Bool)
(Proxy :: Proxy [Bool])
describe "Invariant2" . prop "satisfies the composition law" $
composition2 (Proxy :: Proxy Integer)
(Proxy :: Proxy Bool)
(Proxy :: Proxy Integer)
(Proxy :: Proxy Bool)
(Proxy :: Proxy (Bool,Bool))
-----
composition1
:: (Eq (f c), Show (f c), Invariant f)
=> proxy b -> proxy c -> proxy (f a)
-> Fun b c -> Fun c b
-> Fun a b -> Fun b a
-> f a
-> Property
composition1
_ _ _
(Fun _ f) (Fun _ f')
(Fun _ g) (Fun _ g')
x =
(invmap f f' . invmap g g') x
=== invmap (f . g) (g' . f') x
composition2
:: (Eq (f c1 c2), Show (f c1 c2), Invariant2 f)
=> proxy b1 -> proxy c1 -> proxy b2 -> proxy c2 -> proxy (f a1 a2)
-> Fun b1 c1 -> Fun c1 b1 -> Fun b2 c2 -> Fun c2 b2
-> Fun a1 b1 -> Fun b1 a1 -> Fun a2 b2 -> Fun b2 a2
-> f a1 a2
-> Property
composition2
_ _ _ _ _
(Fun _ f1) (Fun _ f1') (Fun _ f2) (Fun _ f2')
(Fun _ g1) (Fun _ g1') (Fun _ g2) (Fun _ g2')
x =
(invmap2 f1 f1' f2 f2' . invmap2 g1 g1' g2 g2') x
=== invmap2 (f1 . g1) (g1' . f1') (f2 . g2) (g2' . f2') x
invariant-0.6.3/test/Spec.hs 0000644 0000000 0000000 00000000054 07346545000 014110 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
invariant-0.6.3/test/THSpec.hs 0000644 0000000 0000000 00000016672 07346545000 014361 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE RoleAnnotations #-}
#endif
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
#endif
module THSpec (main, spec) where
import Data.Functor.Invariant
import Data.Functor.Invariant.TH
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (Arbitrary)
-------------------------------------------------------------------------------
-- Adapted from the test cases from
-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch
-- Plain data types
data Strange a b c
= T1 a b c
| T2 [a] [b] [c] -- lists
| T3 [[a]] [[b]] [[c]] -- nested lists
| T4 (c,(b,b),(c,c)) -- tuples
| T5 ([c],Strange a b c) -- tycons
| T6 (b -> c) -- function types
| T7 (b -> (c,a)) -- functions and tuples
| T8 ((c -> b) -> a) -- continuation
data NotPrimitivelyRecursive a b
= S1 (NotPrimitivelyRecursive (a,a) (b, a))
| S2 a
| S3 b
newtype Compose f g a b = Compose (f (g a b))
deriving (Arbitrary, Eq, Show)
data ComplexConstraint f a b = ComplexConstraint (f Int Int (f Bool Bool a,a,b))
data Universal a
= Universal (forall b. (b,[a]))
| Universal2 (forall f. Invariant f => (f a))
| Universal3 (forall a. a -> Int) -- reuse a
| NotReallyUniversal (forall b. a)
data Existential b
= forall a. ExistentialList [a]
| forall f. Invariant f => ExistentialFunctor (f b)
| forall b. SneakyUseSameName (b -> Bool)
type IntFun a b = b -> a
data IntFunD a b = IntFunD (IntFun a b)
data Empty1 a b
data Empty2 a b
#if __GLASGOW_HASKELL__ >= 708
type role Empty2 nominal nominal
#endif
data TyCon18 a b c = TyCon18 c (TyCon18 a a c)
data TyCon19 a b
= TyCon19a (forall c. c -> (forall d. a -> d) -> a)
| TyCon19b (Int -> forall c. c -> b)
type family F :: * -> * -> *
type instance F = Either
data TyCon20 a b = TyCon20 (F a b)
-- Data families
data family StrangeFam a b c
data instance StrangeFam a b c
= T1Fam a b c
| T2Fam [a] [b] [c] -- lists
| T3Fam [[a]] [[b]] [[c]] -- nested lists
| T4Fam (c,(b,b),(c,c)) -- tuples
| T5Fam ([c],Strange a b c) -- tycons
| T6Fam (b -> c) -- function types
| T7Fam (b -> (c,a)) -- functions and tuples
| T8Fam ((c -> b) -> a) -- continuation
data family NotPrimitivelyRecursiveFam a b
data instance NotPrimitivelyRecursiveFam a b
= S1Fam (NotPrimitivelyRecursive (a,a) (b, a))
| S2Fam a
| S3Fam b
data family ComposeFam (f :: * -> *) (g :: * -> * -> *) a b
newtype instance ComposeFam f g a b = ComposeFam (f (g a b))
deriving (Arbitrary, Eq, Show)
data family ComplexConstraintFam (f :: * -> * -> * -> *) a b
data instance ComplexConstraintFam f a b =
ComplexConstraintFam (f Int Int (f Bool Bool a,a,b))
data family UniversalFam a
data instance UniversalFam a
= UniversalFam (forall b. (b,[a]))
| Universal2Fam (forall f. Invariant f => (f a))
| Universal3Fam (forall a. a -> Int) -- reuse a
| NotReallyUniversalFam (forall b. a)
data family ExistentialFam b
data instance ExistentialFam b
= forall a. ExistentialListFam [a]
| forall f. Invariant f => ExistentialFunctorFam (f b)
| forall b. SneakyUseSameNameFam (b -> Bool)
data family IntFunDFam a b
data instance IntFunDFam a b = IntFunDFam (IntFun a b)
data family TyFamily18 x y z
data instance TyFamily18 a b c = TyFamily18 c (TyFamily18 a a c)
data family TyFamily19 x y
data instance TyFamily19 a b
= TyFamily19a (forall c. c -> (forall d. a -> d) -> a)
| TyFamily19b (Int -> forall c. c -> b)
data family TyFamily20 x y
data instance TyFamily20 a b = TyFamily20 (F a b)
-------------------------------------------------------------------------------
-- Plain data types
$(deriveInvariant ''Strange)
$(deriveInvariant2 ''Strange)
$(deriveInvariant ''NotPrimitivelyRecursive)
$(deriveInvariant2 ''NotPrimitivelyRecursive)
instance (Invariant f, Invariant (g a)) =>
Invariant (Compose f g a) where
invmap = $(makeInvmap ''Compose)
$(deriveInvariant2 ''Compose)
instance Invariant (f Int Int) =>
Invariant (ComplexConstraint f a) where
invmap = $(makeInvmap ''ComplexConstraint)
instance (Invariant2 (f Bool), Invariant2 (f Int)) =>
Invariant2 (ComplexConstraint f) where
invmap2 = $(makeInvmap2 ''ComplexConstraint)
$(deriveInvariant ''Universal)
$(deriveInvariant ''Existential)
$(deriveInvariant ''IntFunD)
$(deriveInvariant2 ''IntFunD)
$(deriveInvariant ''Empty1)
$(deriveInvariant2 ''Empty1)
-- Use EmptyCase here
$(deriveInvariantOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)
$(deriveInvariant2Options defaultOptions{emptyCaseBehavior = True} ''Empty2)
$(deriveInvariant ''TyCon18)
$(deriveInvariant2 ''TyCon18)
$(deriveInvariant ''TyCon19)
$(deriveInvariant2 ''TyCon19)
$(deriveInvariant ''TyCon20)
$(deriveInvariant2 ''TyCon20)
#if MIN_VERSION_template_haskell(2,7,0)
-- Data Families
$(deriveInvariant 'T1Fam)
$(deriveInvariant2 'T2Fam)
$(deriveInvariant 'S1Fam)
$(deriveInvariant2 'S2Fam)
instance (Invariant f, Invariant (g a)) =>
Invariant (ComposeFam f g a) where
invmap = $(makeInvmap 'ComposeFam)
$(deriveInvariant2 'ComposeFam)
instance Invariant (f Int Int) =>
Invariant (ComplexConstraintFam f a) where
invmap = $(makeInvmap 'ComplexConstraintFam)
instance (Invariant2 (f Bool), Invariant2 (f Int)) =>
Invariant2 (ComplexConstraintFam f) where
invmap2 = $(makeInvmap2 'ComplexConstraintFam)
$(deriveInvariant 'UniversalFam)
$(deriveInvariant 'ExistentialListFam)
$(deriveInvariant 'IntFunDFam)
$(deriveInvariant2 'IntFunDFam)
$(deriveInvariant 'TyFamily18)
$(deriveInvariant2 'TyFamily18)
$(deriveInvariant 'TyFamily19a)
$(deriveInvariant2 'TyFamily19a)
$(deriveInvariant 'TyFamily20)
$(deriveInvariant2 'TyFamily20)
#endif
-------------------------------------------------------------------------------
-- | Verifies that @invmap id id = id@ (the other 'invmap' law follows
-- as a free theorem:
-- https://www.fpcomplete.com/user/edwardk/snippets/fmap).
prop_invmapLaws :: (Eq (f a), Show (f a), Invariant f) => f a -> Expectation
prop_invmapLaws x = invmap id id x `shouldBe` x
-- | Verifies that @invmap2 id id id id = id@.
prop_invmap2Laws :: (Eq (f a b), Show (f a b), Invariant2 f) => f a b -> Expectation
prop_invmap2Laws x = invmap2 id id id id x `shouldBe` x
-------------------------------------------------------------------------------
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "Compose Maybe Either Int Int" $ do
prop "satisfies the invmap laws" (prop_invmapLaws :: Compose Maybe Either Int Int -> Expectation)
prop "satisfies the invmap2 laws" (prop_invmap2Laws :: Compose Maybe Either Int Int -> Expectation)
#if MIN_VERSION_template_haskell(2,7,0)
describe "ComposeFam Maybe Either Int Int" $ do
prop "satisfies the invmap laws" (prop_invmapLaws :: ComposeFam Maybe Either Int Int -> Expectation)
prop "satisfies the invmap2 laws" (prop_invmap2Laws :: ComposeFam Maybe Either Int Int -> Expectation)
#endif