invariant 0.1.2 → 0.2

raw patch · 8 files changed

+2187/−156 lines, 8 filesdep +arraydep +bifunctorsdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: array, bifunctors, containers, ghc-prim, profunctors, semigroups, stm, tagged, template-haskell, transformers, transformers-compat, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• Data/Functor/Invariant.hs +0/−125
• invariant.cabal +47/−31
• src/Data/Functor/Invariant.hs +738/−0
• src/Data/Functor/Invariant/TH.hs +785/−0
• src/Data/Functor/Invariant/TH/Internal.hs +437/−0
• test/InvariantSpec.hs +60/−0
• test/THSpec.hs +105/−0

@@ -1,3 +1,18 @@+# 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` 

@@ -1,125 +0,0 @@-module Data.Functor.Invariant (Invariant(..), Invariant2(..)) where--import Text.ParserCombinators.ReadP (ReadP)-import Text.ParserCombinators.ReadPrec (ReadPrec)--import qualified Control.Category as Cat-import Control.Arrow (Arrow(..))-import Control.Applicative (Const(Const), ZipList)-import Control.Applicative (WrappedMonad, WrappedArrow(WrapArrow))--import Control.Monad.ST (ST)--import Data.Functor.Contravariant-import Data.Functor.Contravariant.Compose-import Data.Monoid (Dual(Dual), Endo(Endo))------- | 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-------- | 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------instance Invariant Maybe where invmap = flip $ const fmap-instance Invariant [] where invmap = flip $ const fmap-instance Invariant IO where invmap = flip $ const fmap-instance Invariant (ST s) where invmap = flip $ const fmap-instance Invariant ReadP where invmap = flip $ const fmap-instance Invariant ReadPrec where invmap = flip $ const fmap-instance Invariant ((->) a) where invmap = flip $ const fmap-instance Invariant (Either a) where invmap = flip $ const fmap-instance Invariant ((,) a) where invmap = flip $ const fmap-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)--instance Invariant2 (->) where invmap2 _ f' g _ = (g .) . (. f')-instance Invariant2 Either where-  invmap2 f _ _ _ (Left  x) = Left  $ f x-  invmap2 _ _ g _ (Right y) = Right $ g y-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)-------- | @Control.Applicative@-instance Invariant (Const a) where invmap _ _ (Const x) = Const x--- | @Control.Applicative@-instance Invariant ZipList where invmap = flip $ const fmap--- | @Control.Applicative@-instance Monad m => Invariant (WrappedMonad m) where invmap = flip $ const fmap--- | @Control.Applicative@-instance Arrow arr => Invariant (WrappedArrow arr a) where-  invmap f _ (WrapArrow x) = WrapArrow $ ((arr f) Cat.. x)--- | @Control.Applicative@-instance Invariant2 Const where invmap2 f _ _ _ (Const x) = Const (f x)--- | @Control.Applicative@-instance Arrow arr => Invariant2 (WrappedArrow arr) where-  invmap2 _ f' g _ (WrapArrow x) = WrapArrow $ arr g Cat.. x Cat.. arr f'---- | @Data.Monoid@-instance Invariant Dual where invmap f _ (Dual x) = Dual (f x)---- | @Data.Monoid@-instance Invariant Endo where-  invmap f g (Endo x) = Endo (f . x . g)---- | from the @contravariant@ package-instance Invariant Predicate where invmap = const contramap--- | from the @contravariant@ package-instance Invariant Comparison where invmap = const contramap--- | from the @contravariant@ package-instance Invariant Equivalence where invmap = const contramap--- | from the @contravariant@ package-instance Invariant (Op a) where invmap = const contramap--- | from the @contravariant@ package-instance Invariant2 Op where-  invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x-------- | from the @contravariant@ package-instance (Invariant f, Invariant g) => Invariant (Compose f g) where-  invmap f g (Compose x) = 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

@@ -1,37 +1,53 @@-name: invariant-version: 0.1.2-synopsis: Haskell 98 invariant functors-description: Haskell 98 invariant functors--category: Control, Data--license: BSD3-license-file: LICENSE-author: Nicolas Frisby <nicolas.frisby@gmail.com>-maintainer: Nicolas Frisby <nicolas.frisby@gmail.com>, Ryan Scott <ryan.gl.scott@ku.edu>--build-type: Simple-cabal-version:  >= 1.9.2-extra-source-files: CHANGELOG.md, README.md+name:                invariant+version:             0.2+synopsis:            Haskell 98 invariant functors+description:         Haskell 98 invariant functors+category:            Control, Data+license:             BSD3+license-file:        LICENSE+homepage:            https://github.com/nfrisby/invariant-functors+bug-reports:         https://github.com/nfrisby/invariant-functors/issues+author:              Nicolas Frisby <nicolas.frisby@gmail.com>+maintainer:          Nicolas Frisby <nicolas.frisby@gmail.com>,+                     Ryan Scott <ryan.gl.scott@ku.edu>+build-type:          Simple+cabal-version:       >= 1.9.2+extra-source-files:  CHANGELOG.md, README.md  source-repository head-  type:     git-  location: git://github.com/nfrisby/invariant-functors.git+  type:                git+  location:            https://github.com/nfrisby/invariant-functors  library-  build-depends:-      base >= 4 && < 5-    , contravariant >= 0.1.2 && < 2-  exposed-modules: Data.Functor.Invariant-  ghc-options: -Wall+  exposed-modules:     Data.Functor.Invariant+                     , Data.Functor.Invariant.TH+  other-modules:       Data.Functor.Invariant.TH.Internal+                     , Paths_invariant+  hs-source-dirs:      src+  build-depends:       array                >= 0.3    && < 0.6+                     , base                 >= 4      && < 5+                     , bifunctors           >= 5      && < 6+                     , containers           >= 0.1    && < 0.6+                     , contravariant        >= 0.1.2  && < 2+                     , ghc-prim+                     , profunctors          >= 5      && < 6+                     , semigroups           >= 0.16.2 && < 1+                     , stm                  >= 2.2    && < 3+                     , tagged               >= 0.7.3  && < 1+                     , template-haskell     >= 2.4    && < 2.11+                     , transformers         >= 0.2    && < 0.5+                     , transformers-compat  >= 0.3    && < 1+                     , unordered-containers >= 0.2.4  && < 0.3+  ghc-options:         -Wall  test-suite qc-tests-  type: exitcode-stdio-1.0-  hs-source-dirs: test-  main-is: Spec.hs-  build-depends:-      base >= 4 && < 5-    , hspec >= 1.8-    , invariant-    , QuickCheck >= 2 && < 3-  ghc-options: -Wall+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       InvariantSpec+                       THSpec+  build-depends:       base       >= 4 && < 5+                     , hspec      >= 1.8+                     , invariant+                     , QuickCheck >= 2 && < 3+  ghc-options:         -Wall

@@ -0,0 +1,738 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702++{-|+Module:      Data.Functor.Invariant+Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 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\":++<http://comonad.com/reader/2008/rotten-bananas/>++-}+module Data.Functor.Invariant+  ( -- * @Invariant@+    Invariant(..)+  , invmapFunctor+  , WrappedFunctor(..)+  , invmapContravariant+  , WrappedContravariant(..)+#if GHC_GENERICS_OK+    -- ** @GHC.Generics@+    -- $ghcgenerics+#endif+    -- * @Invariant2@+  , Invariant2(..)+  , invmap2Bifunctor+  , WrappedBifunctor(..)+  , invmap2Profunctor+  , WrappedProfunctor(..)+  ) where++-- base+import qualified Control.Category as Cat+import           Control.Arrow+import           Control.Applicative as App+import           Control.Exception (Handler(..))+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.ST as Strict (ST)+import qualified Control.Monad.ST.Lazy as Lazy (ST)+import           Data.Functor.Identity (Identity)+#if __GLASGOW_HASKELL__ < 711+import           Data.Ix (Ix)+#endif+import qualified Data.Monoid as Monoid (First(..), Last(..))+#if MIN_VERSION_base(4,8,0)+import           Data.Monoid (Alt(..))+#endif+import           Data.Monoid (Dual(..), Endo(..))+import           Data.Proxy (Proxy(..))+#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 hiding (first)+import           Data.Bifunctor.Biff+import           Data.Bifunctor.Clown+import           Data.Bifunctor.Flip+import           Data.Bifunctor.Join+import           Data.Bifunctor.Joker+import qualified Data.Bifunctor.Product as Bifunctors+import           Data.Bifunctor.Tannen+import           Data.Bifunctor.Wrapped++-- 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.Closed+import           Data.Profunctor.Codensity+import           Data.Profunctor.Composition+import           Data.Profunctor.Ran+import           Data.Profunctor.Tambara++-- semigroups+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Semigroup as Semigroup (First(..), Last(..), Option(..))+import           Data.Semigroup (Min(..), Max(..), Arg(..))++-- 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.Error (ErrorT(..))+import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import           Control.Monad.Trans.Identity (IdentityT, mapIdentityT)+import           Control.Monad.Trans.List (ListT, mapListT)+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)+import qualified Data.Functor.Compose as Transformers (Compose(..))+import           Data.Functor.Constant (Constant(..))+import           Data.Functor.Product as Transformers (Product(..))+import           Data.Functor.Reverse (Reverse(..))+import           Data.Functor.Sum as Transformers (Sum(..))++-- 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++-- | 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++-------------------------------------------------------------------------------+-- 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.Exception@+instance Invariant Handler where+  invmap f _ (Handler h) = Handler (fmap f . h)++-- | from @Data.Functor.Identity@+instance Invariant Identity 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)+#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 @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 (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 = invmap2 id id+-- | 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 @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 Invariant2 p => Invariant (Codensity p a) where+  invmap = invmap2 id id+-- | 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 Invariant2 p => Invariant (Cotambara p a) where+  invmap = invmap2 id id++-- | from the @semigroups@ package+instance Invariant NonEmpty where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant Min where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant Max where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant Semigroup.First where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant Semigroup.Last where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant Semigroup.Option where+  invmap = invmapFunctor+-- | from the @semigroups@ package+instance Invariant (Arg a) where+  invmap = invmapFunctor++-- | 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 (ErrorT e m) where+  invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT+-- | 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 (ListT m) where+  invmap f g = mapListT $ invmap (invmap f g) (invmap g f)+-- | 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 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 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 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 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 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 h (a, w) = (h a, w)+-- | from the @transformers@ package+instance (Invariant f, Invariant g) => Invariant (Transformers.Compose f g) where+  invmap f g (Transformers.Compose x) =+    Transformers.Compose (invmap (invmap f g) (invmap g f) x)+-- | from the @transformers@ package+instance Invariant (Constant a) where+  invmap = invmapFunctor+-- | from the @transformers@ package+instance (Invariant f, Invariant g) => Invariant (Transformers.Product f g) where+  invmap f g (Transformers.Pair x y) = Transformers.Pair (invmap f g x) (invmap f g y)+-- | from the @transformers@ package+instance Invariant f => Invariant (Reverse f) where+  invmap f g (Reverse a) = Reverse (invmap f g a)+-- | from the @transformers@ package+instance (Invariant f, Invariant g) => Invariant (Transformers.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 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 f g = WrapFunctor . invmapFunctor f g . unwrapFunctor++instance Functor f => Functor (WrappedFunctor f) where+  fmap f = WrapFunctor . fmap f . unwrapFunctor++instance Applicative f => Applicative (WrappedFunctor f) where+  pure = WrapFunctor . pure+  WrapFunctor f <*> WrapFunctor x = WrapFunctor $ f <*> x++instance Alternative f => Alternative (WrappedFunctor f) where+  empty = WrapFunctor empty+  WrapFunctor x <|> WrapFunctor y = WrapFunctor $ x <|> y++instance Monad m => Monad (WrappedFunctor m) where+  return = WrapFunctor . return+  WrapFunctor x >>= f = WrapFunctor $ x >>= unwrapFunctor . f++instance MonadPlus m => MonadPlus (WrappedFunctor m) where+  mzero = WrapFunctor mzero+  WrapFunctor x `mplus` WrapFunctor y = WrapFunctor $ x `mplus` y++-------------------------------------------------------------------------------+-- 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 f g = WrapContravariant . invmapContravariant f g . unwrapContravariant++instance Contravariant f => Contravariant (WrappedContravariant f) where+  contramap f = WrapContravariant . contramap f . unwrapContravariant++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 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 (Bifunctors.Product f g) where+  invmap2 f f' g g' (Bifunctors.Pair x y) =+    Bifunctors.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)+-- | 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 f f' g g' = WrapBifunctor . invmap2Bifunctor f f' g g' . unwrapBifunctor++-- | 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 _ f' g _ (Environment l m r) = Environment (g . l) m (r . f')+-- | 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 (Pastro p) where+  invmap2 _ f' g _ (Pastro l m r) = Pastro (g . l) m (r . f')+-- | from the @profunctors@ package+instance Invariant2 p => Invariant2 (Cotambara p) where+  invmap2 f f' g g' (Cotambara p) =+    Cotambara $ invmap2 (left f) (left f') (left g) (left g') p+-- | from the @profunctors@ package+instance Invariant2 (Copastro p) where+  invmap2 _ f' g _ (Copastro l m r) = Copastro (g . l) m (r . f')++-- | from the @semigroups@ package+instance Invariant2 Arg where+  invmap2 = invmap2Bifunctor++-- | 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 f f' g g' = WrapProfunctor . invmap2Profunctor f f' g g' . unwrapProfunctor++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++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++#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 _ _ _ = 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@; genuinely relying on this instance+-- likely requires writing your 'Generic1' instance by hand+instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where+  invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp+++{- $ghcgenerics++Note: The restriction to Haskell98 prevents the full adoption of+"GHC.Generics", but we are permitted to at least provide @Invariant@+instances for the representation data types. Thus, while the \"ideal\"++@+  instance Invariant f => 'Invariant' (T f)+@++doesn't work --- because Haskell98 precludes our use of+@-XDefaultSignatures@ in the class definition ---, the user only needs+to do slightly more work:++@+  import GHC.Generics (from1,to1)++  instance Invariant f => 'Invariant' (T f) where+    invmap f g = 'to1' . 'invmap' f g . 'from1'+@++Note also that that instance is in fact Haskell98. Unfortunately, one+would require @-XFlexibleContexts@ in order to factor that right-hand+side out as reusable declaration polymorphic in the data type.+-}+#endif

@@ -0,0 +1,785 @@+{-# LANGUAGE CPP #-}++{-|+Module:      Data.Functor.Invariant.TH+Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++Functions to mechanically derive 'Invariant' or 'Invariant2' instances,+or to splice 'invmap' or '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+      -- $deriveInvariant2+    , deriveInvariant2+      -- * @makeInvmap(2)@+      -- $make+    , makeInvmap+    , makeInvmap2+    ) where++import           Data.Functor.Invariant.TH.Internal+import           Data.List+#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)+import qualified Data.Set as Set+#endif++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Ppr+import           Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- User-facing API+-------------------------------------------------------------------------------++{- $deriveInvariant++'deriveInvariant' automatically generates an '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+'Invariant'@ clause to the end of a data declaration. Examples:++@+&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;+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 '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:++@+&#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;+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 '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+  '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 '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@.++* In GHC 7.8, a bug exists that can cause problems when a data family declaration and+  one of its data instances use different type variables, e.g.,++  @+  data family Foo a b c+  data instance Foo Int y z = Foo Int y z+  $('deriveInvariant' 'Foo)+  @++  To avoid this issue, it is recommened that you use the same type variables in the+  same positions in which they appeared in the data family declaration:++  @+  data family Foo a b c+  data instance Foo Int b c = Foo Int b c+  $('deriveInvariant' 'Foo)+  @++-}++-- | Generates an 'Invariant' instance declaration for the given data type or data+-- family instance.+deriveInvariant :: Name -> Q [Dec]+deriveInvariant = deriveInvariantClass Invariant++{- $deriveInvariant2++'deriveInvariant2' automatically generates an '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+'Invariant2'@ clause to the end of a data declaration. Examples:++@+&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;+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 'Invariant'+  constraint, and type variables of kind @* -> * -> *@ are assumed to require an+  '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 '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 '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 'Invariant2' instance declaration for the given data type or data+-- family instance.+deriveInvariant2 :: Name -> Q [Dec]+deriveInvariant2 = 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 '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 'Invariant' instance+for @HigherKinded@ without too much trouble using 'makeInvmap':++@+&#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;+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 'invmap' (without requiring an+-- 'Invariant' instance).+makeInvmap :: Name -> Q Exp+makeInvmap = makeInvmapClass Invariant++-- | Generates a lambda expression which behaves like 'invmap2' (without requiring an+-- 'Invariant2' instance).+makeInvmap2 :: Name -> Q Exp+makeInvmap2 = makeInvmapClass Invariant2++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Derive an Invariant(2) instance declaration (depending on the InvariantClass+-- argument's value).+deriveInvariantClass :: InvariantClass -> Name -> Q [Dec]+deriveInvariantClass iClass tyConName = do+    info <- reify tyConName+    case info of+        TyConI{} -> deriveInvariantPlainTy iClass tyConName+#if MIN_VERSION_template_haskell(2,7,0)+        DataConI{} -> deriveInvariantDataFamInst iClass tyConName+        FamilyI (FamilyD DataFam _ _ _) _ ->+            error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."+        FamilyI (FamilyD TypeFam _ _ _) _ ->+            error $ ns ++ "Cannot use a type family name."+        _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."+#else+        DataConI{} -> dataConIError+        _          -> error $ ns ++ "The name must be of a plain type constructor."+#endif+  where+    ns :: String+    ns = "Data.Functor.Invariant.TH.deriveInvariant: "++-- | Generates an Invariant(2) instance declaration for a plain type constructor.+deriveInvariantPlainTy :: InvariantClass -> Name -> Q [Dec]+deriveInvariantPlainTy iClass tyConName =+    withTyCon tyConName fromCons+  where+    className :: Name+    className = invariantClassNameTable iClass++    fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]+    fromCons ctxt tvbs cons = (:[]) `fmap`+        instanceD (return instanceCxt)+                  (return $ AppT (ConT className) instanceType)+                  (invmapDecs droppedNbs cons)+      where+        (instanceCxt, instanceType, droppedNbs) =+            cxtAndTypePlainTy iClass tyConName ctxt tvbs++#if MIN_VERSION_template_haskell(2,7,0)+-- | Generates an Invariant(2) instance declaration for a data family instance+-- constructor.+deriveInvariantDataFamInst :: InvariantClass -> Name -> Q [Dec]+deriveInvariantDataFamInst iClass dataFamInstName =+    withDataFamInstCon dataFamInstName fromDec+  where+    className :: Name+    className = invariantClassNameTable iClass++    fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]+    fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`+        instanceD (return instanceCxt)+                  (return $ AppT (ConT className) instanceType)+                  (invmapDecs droppedNbs cons)+      where+        (instanceCxt, instanceType, droppedNbs) =+            cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys+#endif++-- | Generates a declaration defining the primary function corresponding to a+-- particular class (invmap for Invariant and invmap2 for Invariant2).+invmapDecs :: [NameBase] -> [Con] -> [Q Dec]+invmapDecs nbs cons =+    [ funD classFuncName+           [ clause []+                    (normalB $ makeInvmapForCons nbs cons)+                    []+           ]+    ]+  where+    classFuncName :: Name+    classFuncName = invmapNameTable . toEnum $ length nbs++-- | Generates a lambda expression which behaves like invmap (for Invariant),+-- or invmap2 (for Invariant2).+makeInvmapClass :: InvariantClass -> Name -> Q Exp+makeInvmapClass iClass tyConName = do+    info <- reify tyConName+    case info of+        TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->+            let nbs = thd3 $ cxtAndTypePlainTy iClass tyConName ctxt tvbs+             in nbs `seq` makeInvmapForCons nbs decs+#if MIN_VERSION_template_haskell(2,7,0)+        DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->+            let nbs = thd3 $ cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys+             in nbs `seq` makeInvmapForCons nbs cons+        FamilyI (FamilyD DataFam _ _ _) _ ->+            error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."+        FamilyI (FamilyD TypeFam _ _ _) _ ->+            error $ ns ++ "Cannot use a type family name."+        _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."+#else+        DataConI{} -> dataConIError+        _          -> error $ ns ++ "The name must be of a plain type constructor."+#endif+  where+    ns :: String+    ns = "Data.Functor.Invariant.TH.makeInvmap: "++-- | Generates a lambda expression for invmap(2) for the given constructors.+-- All constructors must be from the same type.+makeInvmapForCons :: [NameBase] -> [Con] -> Q Exp+makeInvmapForCons nbs cons = do+    let numNbs = length nbs++    value      <- newName "value"+    covMaps    <- newNameList "covMap" numNbs+    contraMaps <- newNameList "contraMap" numNbs++    let tvis     = zip3 nbs covMaps contraMaps+        iClass   = toEnum numNbs+        argNames = concat (transpose [covMaps, contraMaps]) ++ [value]+    lamE (map varP argNames)+        . appsE+        $ [ varE $ invmapConstNameTable iClass+          , if null cons+               then appE (varE errorValName)+                         (stringE $ "Void " ++ nameBase (invmapNameTable iClass))+               else caseE (varE value)+                          (map (makeInvmapForCon iClass tvis) cons)+          ] ++ map varE argNames++-- | Generates a lambda expression for invmap(2) for a single constructor.+makeInvmapForCon :: InvariantClass -> [TyVarInfo] -> Con -> Q Match+makeInvmapForCon iClass tvis (NormalC conName tys) = do+    args <- newNameList "arg" $ length tys+    let argTys = map snd tys+    makeInvmapForArgs iClass tvis conName argTys args+makeInvmapForCon iClass tvis (RecC conName tys) = do+    args <- newNameList "arg" $ length tys+    let argTys = map thd3 tys+    makeInvmapForArgs iClass tvis conName argTys args+makeInvmapForCon iClass tvis (InfixC (_, argTyL) conName (_, argTyR)) = do+    argL <- newName "argL"+    argR <- newName "argR"+    makeInvmapForArgs iClass tvis conName [argTyL, argTyR] [argL, argR]+makeInvmapForCon iClass tvis (ForallC tvbs faCxt con) =+    if any (`predMentionsNameBase` map fst3 tvis) faCxt+       then existentialContextError $ constructorName con+       else makeInvmapForCon iClass (removeForalled tvbs tvis) con++makeInvmapForArgs :: InvariantClass+                  -> [TyVarInfo]+                  -> Name+                  -> [Type]+                  -> [Name]+                  ->  Q Match+makeInvmapForArgs iClass tvis conName tys args =+    let mappedArgs :: [Q Exp]+        mappedArgs = zipWith (makeInvmapForArg iClass conName tvis) tys args+     in match (conP conName $ map varP args)+              (normalB . appsE $ conE conName:mappedArgs)+              []++-- | Generates a lambda expression for invmap(2) for an argument of a constructor.+makeInvmapForArg :: InvariantClass+                 -> Name+                 -> [TyVarInfo]+                 -> Type+                 -> Name+                 -> Q Exp+makeInvmapForArg iClass conName tvis ty tyExpName = do+    ty' <- expandSyn ty+    makeInvmapForArg' iClass conName tvis ty' tyExpName++-- | Generates a lambda expression for invmap(2) for an argument of a+-- constructor, after expanding all type synonyms.+makeInvmapForArg' :: InvariantClass+                  -> Name+                  -> [TyVarInfo]+                  -> Type+                  -> Name+                  -> Q Exp+makeInvmapForArg' iClass conName tvis ty tyExpName =+    appE (makeInvmapForType iClass conName tvis True ty) (varE tyExpName)++-- | Generates a lambda expression for invmap(2) for a specific type.+-- The generated expression depends on the number of type variables.+makeInvmapForType :: InvariantClass+                  -> Name+                  -> [TyVarInfo]+                  -> Bool+                  -> Type+                  -> Q Exp+makeInvmapForType _ _ tvis covariant (VarT tyName) =+    case lookup2 (NameBase tyName) tvis of+         Just (covMap, contraMap) ->+             varE $ if covariant then covMap else contraMap+         Nothing -> do -- Produce a lambda expression rather than id, addressing Trac #7436+             x <- newName "x"+             lamE [varP x] $ varE x+makeInvmapForType iClass conName tvis covariant (SigT ty _) =+    makeInvmapForType iClass conName tvis covariant ty+makeInvmapForType iClass conName tvis covariant (ForallT tvbs _ ty)+    = makeInvmapForType iClass conName (removeForalled tvbs tvis) covariant ty+makeInvmapForType iClass conName tvis covariant ty =+    let tyCon  :: Type+        tyArgs :: [Type]+        tyCon:tyArgs = unapplyTy ty++        numLastArgs :: Int+        numLastArgs = min (fromEnum iClass) (length tyArgs)++        lhsArgs, rhsArgs :: [Type]+        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++        tyVarNameBases :: [NameBase]+        tyVarNameBases = map fst3 tvis++        doubleMap :: (Bool -> Type -> Q Exp) -> [Type] -> [Q Exp]+        doubleMap _ []     = []+        doubleMap f (t:ts) = f covariant t : f (not covariant) t : doubleMap f ts++        mentionsTyArgs :: Bool+        mentionsTyArgs = any (`mentionsNameBase` tyVarNameBases) tyArgs++        makeInvmapTuple :: Type -> Name -> Q Exp+        makeInvmapTuple fieldTy fieldName =+            appE (makeInvmapForType iClass conName tvis covariant fieldTy) $ varE fieldName++     in case tyCon of+             ArrowT | mentionsTyArgs ->+                 let [argTy, resTy] = tyArgs+                  in do x <- newName "x"+                        b <- newName "b"+                        lamE [varP x, varP b] $+                          makeInvmapForType iClass conName tvis covariant resTy `appE` (varE x `appE`+                            (makeInvmapForType iClass conName tvis (not covariant) argTy `appE` varE b))+             TupleT n | n > 0 && mentionsTyArgs -> do+                 x  <- newName "x"+                 xs <- newNameList "x" n+                 lamE [varP x] $ caseE (varE x)+                     [ match (tupP $ map varP xs)+                             (normalB . tupE $ zipWith makeInvmapTuple tyArgs xs)+                             []+                     ]+             _ -> do+                 itf <- isTyFamily tyCon+                 if any (`mentionsNameBase` tyVarNameBases) lhsArgs || (itf && mentionsTyArgs)+                      then outOfPlaceTyVarError conName tyVarNameBases+                      else if any (`mentionsNameBase` tyVarNameBases) rhsArgs+                           then appsE $+                                ( varE (invmapNameTable (toEnum numLastArgs))+                                : doubleMap (makeInvmapForType iClass conName tvis) rhsArgs+                                )+                           else do x <- newName "x"+                                   lamE [varP x] $ varE x++-------------------------------------------------------------------------------+-- Template Haskell reifying and AST manipulation+-------------------------------------------------------------------------------++-- | Extracts a plain type constructor's information.+withTyCon :: Name -- ^ Name of the plain type constructor+          -> (Cxt -> [TyVarBndr] -> [Con] -> Q a)+          -> Q a+withTyCon name f = do+    info <- reify name+    case info of+        TyConI dec ->+            case dec of+                DataD    ctxt _ tvbs cons _ -> f ctxt tvbs cons+                NewtypeD ctxt _ tvbs con  _ -> f ctxt tvbs [con]+                other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data type or newtype."+        _ -> error $ ns ++ "The name must be of a plain type constructor."+  where+    ns :: String+    ns = "Data.Functor.Invariant.TH.withTyCon: "++#if MIN_VERSION_template_haskell(2,7,0)+-- | Extracts a data family name's information.+withDataFam :: Name -- ^ Name of the data family+            -> ([TyVarBndr] -> [Dec] -> Q a)+            -> Q a+withDataFam name f = do+    info <- reify name+    case info of+        FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs+        FamilyI (FamilyD TypeFam _ _    _) _    ->+            error $ ns ++ "Cannot use a type family name."+        other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family name."+  where+    ns :: String+    ns = "Data.Functor.Invariant.TH.withDataFam: "++-- | Extracts a data family instance constructor's information.+withDataFamInstCon :: Name -- ^ Name of the data family instance constructor+                   -> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)+                   -> Q a+withDataFamInstCon dficName f = do+    dficInfo <- reify dficName+    case dficInfo of+        DataConI _ _ parentName _ -> do+            parentInfo <- reify parentName+            case parentInfo of+                FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->+                    let sameDefDec = flip find decs $ \dec ->+                          case dec of+                              DataInstD    _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'+                              NewtypeInstD _ _ _ con   _ -> dficName == constructorName con+                              _ -> error $ ns ++ "Must be a data or newtype instance."++                        (ctxt, instTys, cons) = case sameDefDec of+                              Just (DataInstD    ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')+                              Just (NewtypeInstD ctxt' _ instTys' con   _) -> (ctxt', instTys', [con])+                              _ -> error $ ns ++ "Could not find data or newtype instance constructor."++                    in f famTvbs ctxt parentName instTys cons+                _ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."+        other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family instance constructor."+  where+    ns :: String+    ns = "Data.Functor.Invariant.TH.withDataFamInstCon: "+#endif++-- | Deduces the Invariant(2) instance context, instance head, and eta-reduced+-- type variables for a plain data type constructor.+cxtAndTypePlainTy :: InvariantClass -- Invariant or Invariant2+                  -> Name           -- The datatype's name+                  -> Cxt            -- The datatype context+                  -> [TyVarBndr]    -- The type variables+                  -> (Cxt, Type, [NameBase])+cxtAndTypePlainTy iClass tyConName dataCxt tvbs =+    if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables+       then derivingKindError iClass tyConName+    else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context+       then datatypeContextError tyConName instanceType+    else (instanceCxt, instanceType, droppedNbs)+  where+    instanceCxt :: Cxt+    instanceCxt = map (applyInvariantConstraint)+                $ filter (needsConstraint iClass . tvbKind) remaining++    instanceType :: Type+    instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining++    remainingLength :: Int+    remainingLength = length tvbs - fromEnum iClass++    remaining, dropped :: [TyVarBndr]+    (remaining, dropped) = splitAt remainingLength tvbs++    droppedKinds :: [Kind]+    droppedKinds = map tvbKind dropped++    droppedNbs :: [NameBase]+    droppedNbs = map (NameBase . tvbName) dropped++#if MIN_VERSION_template_haskell(2,7,0)+-- | Deduces the Invariant(2) instance context, instance head, and eta-reduced+-- type variables for a data family instnce constructor.+cxtAndTypeDataFamInstCon :: InvariantClass -- Invariant or Invariant2+                         -> Name           -- The data family name+                         -> Cxt            -- The datatype context+                         -> [TyVarBndr]    -- The data family declaration's type variables+                         -> [Type]         -- The data family instance types+                         -> (Cxt, Type, [NameBase])+cxtAndTypeDataFamInstCon iClass parentName dataCxt famTvbs instTysAndKinds =+    if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables+       then derivingKindError iClass parentName+    else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context+       then datatypeContextError parentName instanceType+    else if canEtaReduce remaining dropped -- If it is safe to drop the type variables+       then (instanceCxt, instanceType, droppedNbs)+    else etaReductionError instanceType+  where+    instanceCxt :: Cxt+    instanceCxt = map (applyInvariantConstraint)+                $ filter (needsConstraint iClass . tvbKind) lhsTvbs++    -- We need to make sure that type variables in the instance head which have+    -- Invariant(2) constraints aren't poly-kinded, e.g.,+    --+    -- @+    -- instance Invariant f => Invariant (Foo (f :: k)) where+    -- @+    --+    -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').+    instanceType :: Type+    instanceType = applyTyCon parentName+                 $ map unSigT remaining++    remainingLength :: Int+    remainingLength = length famTvbs - fromEnum iClass++    remaining, dropped :: [Type]+    (remaining, dropped) = splitAt remainingLength rhsTypes++    droppedKinds :: [Kind]+    droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs++    droppedNbs :: [NameBase]+    droppedNbs = map varTToNameBase dropped++    -- We need to be mindful of an old GHC bug which causes kind variables to appear in+    -- @instTysAndKinds@ (as the name suggests) if+    --+    --   (1) @PolyKinds@ is enabled+    --   (2) either GHC 7.6 or 7.8 is being used (for more info, see+    --       https://ghc.haskell.org/trac/ghc/ticket/9692).+    --+    -- Since Template Haskell doesn't seem to have a mechanism for detecting which+    -- language extensions are enabled, we do the next-best thing by counting+    -- the number of distinct kind variables in the data family declaration, and+    -- then dropping that number of entries from @instTysAndKinds@.+    instTypes :: [Type]+    instTypes =+# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))+        instTysAndKinds+# else+        drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)+             instTysAndKinds+# endif++    lhsTvbs :: [TyVarBndr]+    lhsTvbs = map (uncurry replaceTyVarName)+            . filter (isTyVar . snd)+            . take remainingLength+            $ zip famTvbs rhsTypes++    -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable+    -- in @instTypes@ are provided (as a result of this extremely annoying bug:+    -- https://ghc.haskell.org/trac/ghc/ticket/9692). This is pretty inconvenient,+    -- as it makes it impossible to come up with the correct Invariant(2)+    -- instances in some cases. For example, consider the following code:+    --+    -- @+    -- data family Foo a b c+    -- data instance Foo Int y z = Foo Int y z+    -- $(deriveInvariant2 'Foo)+    -- @+    --+    -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of+    -- either of type variables in the data instance (@y@ and @z@). As a result, we+    -- won't know which fields of the 'Foo' constructor to apply the map functions,+    -- which will result in an incorrect instance. Urgh.+    --+    -- A workaround is to ensure that you use the exact same type variables, in the+    -- exact same order, in the data family declaration and any data or newtype+    -- instances:+    --+    -- @+    -- data family Foo a b c+    -- data instance Foo Int b c = Foo Int b c+    -- $(deriveInvariant2 'Foo)+    -- @+    --+    -- Thankfully, other versions of GHC don't seem to have this bug.+    rhsTypes :: [Type]+    rhsTypes =+# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+            instTypes ++ map tvbToType+                             (drop (length instTypes)+                                   famTvbs)+# else+            instTypes+# endif+#endif++-- | Given a TyVarBndr, apply an Invariant(2) constraint to it, depending+-- on its kind.+applyInvariantConstraint :: TyVarBndr -> Pred+applyInvariantConstraint (PlainTV  _)         = error "Cannot constrain type of kind *"+applyInvariantConstraint (KindedTV name kind) = applyClass className name+  where+    className :: Name+    className = invariantClassNameTable . toEnum $ numKindArrows kind++-- | Can a kind signature inhabit an Invariant constraint?+--+-- Invariant:  Kind k1 -> k2+-- Invariant2: Kind k1 -> k2 -> k3+needsConstraint :: InvariantClass -> Kind -> Bool+needsConstraint iClass kind =+       fromEnum iClass >= nka+    && nka >= fromEnum Invariant+    && canRealizeKindStarChain kind+  where+   nka :: Int+   nka = numKindArrows kind++-------------------------------------------------------------------------------+-- 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 -> a+derivingKindError iClass tyConName = error+    . 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 $ invariantClassNameTable iClass++-- | The data type has a DatatypeContext which mentions one of the eta-reduced+-- type variables.+datatypeContextError :: Name -> Type -> a+datatypeContextError dataName instanceType = error+    . 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 -> a+existentialContextError conName = error+    . 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 -> [NameBase] -> a+outOfPlaceTyVarError conName tyVarNames = error+    . showString "Constructor ‘"+    . showString (nameBase conName)+    . showString "‘ must use the type variable(s) "+    . showsPrec 0 tyVarNames+    . showString " only in the last argument(s) of a data type"+    $ ""++#if MIN_VERSION_template_haskell(2,7,0)+-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> a+etaReductionError instanceType = error $+    "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+    ++ pprint instanceType+#else+-- | Template Haskell didn't list all of a data family's instances upon reification+-- until template-haskell-2.7.0.0, which is necessary for a derived Invariant instance+-- to work.+dataConIError :: a+dataConIError = error+    . showString "Cannot use a data constructor."+    . showString "\n\t(Note: if you are trying to derive Invariant for a type family,"+    . showString "\n\tuse GHC >= 7.4 instead.)"+    $ ""+#endif

@@ -0,0 +1,437 @@+{-# LANGUAGE CPP #-}++{-|+Module:      Data.Functor.Invariant.TH.Internal+Copyright:   (C) 2012-2015 Nicolas Frisby, (C) 2015 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.Function (on)+import           Data.List+import qualified Data.Map as Map (fromList, lookup)+import           Data.Map (Map)+import           Data.Maybe+import qualified Data.Set as Set+import           Data.Set (Set)++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Syntax++#ifndef CURRENT_PACKAGE_KEY+import           Data.Version (showVersion)+import           Paths_invariant (version)+#endif++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++-- | Expands all type synonyms in a type. Written by Dan Rosén in the+-- @genifunctors@ package (licensed under BSD3).+expandSyn :: Type -> Q Type+expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t+expandSyn t@AppT{}            = expandSynApp t []+expandSyn t@ConT{}            = expandSynApp t []+expandSyn (SigT t _)          = expandSyn t   -- Ignore kind synonyms+expandSyn t                   = return t++expandSynApp :: Type -> [Type] -> Q Type+expandSynApp (AppT t1 t2) ts = do+    t2' <- expandSyn t2+    expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts+expandSynApp t@(ConT n) ts = do+    info <- reify n+    case info of+        TyConI (TySynD _ tvs rhs) ->+            let (ts', ts'') = splitAt (length tvs) ts+                subs = mkSubst tvs ts'+                rhs' = subst subs rhs+             in expandSynApp rhs' ts''+        _ -> return $ foldl' AppT t ts+expandSynApp t ts = do+    t' <- expandSyn t+    return $ foldl' AppT t' ts++type Subst = Map Name Type++mkSubst :: [TyVarBndr] -> [Type] -> Subst+mkSubst vs ts =+   let vs' = map un vs+       un (PlainTV v)    = v+       un (KindedTV v _) = v+   in Map.fromList $ zip vs' ts++subst :: Subst -> Type -> Type+subst subs (ForallT v c t) = ForallT v c $ subst subs t+subst subs t@(VarT n)      = fromMaybe t $ Map.lookup n subs+subst subs (AppT t1 t2)    = AppT (subst subs t1) (subst subs t2)+subst subs (SigT t k)      = SigT (subst subs t) k+subst _ t                  = t++-------------------------------------------------------------------------------+-- 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++invmapConstNameTable :: InvariantClass -> Name+invmapConstNameTable Invariant  = invmapConstValName+invmapConstNameTable Invariant2 = invmap2ConstValName++invariantClassNameTable :: InvariantClass -> Name+invariantClassNameTable Invariant  = invariantTypeName+invariantClassNameTable Invariant2 = invariant2TypeName++invmapNameTable :: InvariantClass -> Name+invmapNameTable Invariant  = invmapValName+invmapNameTable 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 #-}++-------------------------------------------------------------------------------+-- NameBase+-------------------------------------------------------------------------------++-- | A wrapper around Name which only uses the 'nameBase' (not the entire Name)+-- to compare for equality. For example, if you had two Names a_123 and a_456,+-- they are not equal as Names, but they are equal as NameBases.+--+-- This is useful when inspecting type variables, since a type variable in an+-- instance context may have a distinct Name from a type variable within an+-- actual constructor declaration, but we'd want to treat them as the same+-- if they have the same 'nameBase' (since that's what the programmer uses to+-- begin with).+newtype NameBase = NameBase { getName :: Name }++getNameBase :: NameBase -> String+getNameBase = nameBase . getName++instance Eq NameBase where+    (==) = (==) `on` getNameBase++instance Ord NameBase where+    compare = compare `on` getNameBase++instance Show NameBase where+    showsPrec p = showsPrec p . getNameBase++-- | A NameBase paired with the name of its map functions. For example, when deriving+-- Invariant2, its list of TyVarInfos might look like [(a, 'covMap1, 'contraMap1),+-- (b, 'covMap2, 'contraMap2)].+type TyVarInfo = (NameBase, Name, Name)++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++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++-- | Extracts the name of a constructor.+constructorName :: Con -> Name+constructorName (NormalC name      _  ) = name+constructorName (RecC    name      _  ) = name+constructorName (InfixC  _    name _  ) = name+constructorName (ForallC _    _    con) = constructorName con++-- | 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]++-- | Remove any occurrences of a forall-ed type variable from a list of @TyVarInfo@s.+removeForalled :: [TyVarBndr] -> [TyVarInfo] -> [TyVarInfo]+removeForalled tvbs = filter (not . foralled tvbs)+  where+    foralled :: [TyVarBndr] -> TyVarInfo -> Bool+    foralled tvbs' tvi = fst3 tvi `elem` map (NameBase . tvbName) tvbs'++-- | Extracts the name from a TyVarBndr.+tvbName :: TyVarBndr -> Name+tvbName (PlainTV  name)   = name+tvbName (KindedTV name _) = name++-- | Extracts the kind from a TyVarBndr.+tvbKind :: TyVarBndr -> Kind+tvbKind (PlainTV  _)   = starK+tvbKind (KindedTV _ k) = k++-- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).+replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr+replaceTyVarName tvb            (SigT t _) = replaceTyVarName tvb t+replaceTyVarName (PlainTV  _)   (VarT n)   = PlainTV  n+replaceTyVarName (KindedTV _ k) (VarT n)   = KindedTV n k+replaceTyVarName tvb            _          = tvb++-- | 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 nbs -- 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 (`mentionsNameBase` nbs) remaining)+  where+    nbs :: [NameBase]+    nbs = map varTToNameBase dropped++-- | Extract the Name from a type variable.+varTToName :: Type -> Name+varTToName (VarT n)   = n+varTToName (SigT t _) = varTToName t+varTToName _          = error "Not a type variable!"++-- | Extract the NameBase from a type variable.+varTToNameBase :: Type -> NameBase+varTToNameBase = NameBase . varTToName++-- | 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++-- | Is the given type a type family constructor (and not a data family constructor)?+isTyFamily :: Type -> Q Bool+isTyFamily (ConT n) = do+    info <- reify n+    return $ case info of+#if MIN_VERSION_template_haskell(2,7,0)+         FamilyI (FamilyD TypeFam _ _ _) _ -> True+#else+         TyConI  (FamilyD TypeFam _ _ _)   -> True+#endif+         _ -> False+isTyFamily _ = return False++-- | 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 NameBases in the list?+mentionsNameBase :: Type -> [NameBase] -> Bool+mentionsNameBase = go Set.empty+  where+    go :: Set NameBase -> Type -> [NameBase] -> Bool+    go foralls (ForallT tvbs _ t) nbs =+        go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs+    go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs+    go foralls (SigT t _)   nbs = go foralls t nbs+    go foralls (VarT n)     nbs = varNb `elem` nbs && not (varNb `Set.member` foralls)+      where+        varNb = NameBase n+    go _       _            _   = False++-- | Does an instance predicate mention any of the NameBases in the list?+predMentionsNameBase :: Pred -> [NameBase] -> Bool+#if MIN_VERSION_template_haskell(2,10,0)+predMentionsNameBase = mentionsNameBase+#else+predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys+predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs+#endif++-- | The number of arrows that compose the spine of a kind signature+-- (e.g., (* -> *) -> k -> * has two arrows on its spine).+numKindArrows :: Kind -> Int+numKindArrows k = length (uncurryKind k) - 1++-- | Construct a type via curried application.+applyTy :: Type -> [Type] -> Type+applyTy = 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]+unapplyTy = reverse . go+  where+    go :: Type -> [Type]+    go (AppT t1 t2) = t2:go t1+    go (SigT t _)   = go t+    go t            = [t]++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- (Int -> String) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- [Int -> String, Char, ()]+-- @+uncurryTy :: Type -> [Type]+uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2+uncurryTy (SigT t _)                 = uncurryTy t+uncurryTy t                          = [t]++-- | Like uncurryType, except on a kind level.+uncurryKind :: Kind -> [Kind]+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = uncurryTy+#else+uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2+uncurryKind k              = [k]+#endif++wellKinded :: [Kind] -> Bool+wellKinded = all canRealizeKindStar++-- | Of form k1 -> k2 -> ... -> kn, where k is either a single kind variable or *.+canRealizeKindStarChain :: Kind -> Bool+canRealizeKindStarChain = all canRealizeKindStar . uncurryKind++canRealizeKindStar :: Kind -> Bool+canRealizeKindStar k = case uncurryKind k of+    [k'] -> case k' of+#if MIN_VERSION_template_haskell(2,8,0)+                 StarT    -> True+                 (VarT _) -> True -- Kind k can be instantiated with *+#else+                 StarK    -> True+#endif+                 _ -> False+    _ -> False++createKindChain :: Int -> Kind+createKindChain = go starK+  where+    go :: Kind -> Int -> Kind+    go k 0  = k+#if MIN_VERSION_template_haskell(2,8,0)+    go k n = n `seq` go (AppT (AppT ArrowT StarT) k) (n - 1)+#else+    go k n = n `seq` go (ArrowK StarK k) (n - 1)+#endif++distinctKindVars :: Kind -> Set Name+#if MIN_VERSION_template_haskell(2,8,0)+distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2+distinctKindVars (SigT k _)   = distinctKindVars k+distinctKindVars (VarT k)     = Set.singleton k+#endif+distinctKindVars _            = Set.empty++tvbToType :: TyVarBndr -> Type+tvbToType (PlainTV n)    = VarT n+tvbToType (KindedTV n k) = SigT (VarT n) k++-------------------------------------------------------------------------------+-- Manually quoted names+-------------------------------------------------------------------------------++-- 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"++errorValName :: Name+errorValName = mkNameG_v "base" "GHC.Err" "error"

@@ -0,0 +1,60 @@+module InvariantSpec (main, spec) where++import Data.Functor.Invariant+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck+import Test.QuickCheck.Function++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

@@ -0,0 +1,105 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+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++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 = ComplexContraint (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)++-------------------------------------------------------------------------------++$(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)++-------------------------------------------------------------------------------++-- | 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), Invariant f) => f a -> Bool+prop_invmapLaws x = invmap id id x == x++-- | Verifies that @invmap2 id id id id = id@.+prop_invmap2Laws :: (Eq (f a b), Invariant2 f) => f a b -> Bool+prop_invmap2Laws x = invmap2 id id id id x == 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 -> Bool)+        prop "satisfies the invmap2 laws" (prop_invmap2Laws :: Compose Maybe Either Int Int -> Bool)