diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/Data/Functor/Invariant.hs b/Data/Functor/Invariant.hs deleted file mode 100644 --- a/Data/Functor/Invariant.hs +++ /dev/null @@ -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 diff --git a/invariant.cabal b/invariant.cabal --- a/invariant.cabal +++ b/invariant.cabal @@ -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 -maintainer: Nicolas Frisby , Ryan Scott - -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 +maintainer: Nicolas Frisby , + Ryan Scott +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 diff --git a/src/Data/Functor/Invariant.hs b/src/Data/Functor/Invariant.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant.hs @@ -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\": + + + +-} +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 diff --git a/src/Data/Functor/Invariant/TH.hs b/src/Data/Functor/Invariant/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/TH.hs @@ -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: + +@ +{-# 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 '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 '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: + +@ +{-# 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 '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': + +@ +{-# 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 '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 diff --git a/src/Data/Functor/Invariant/TH/Internal.hs b/src/Data/Functor/Invariant/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/TH/Internal.hs @@ -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" diff --git a/test/InvariantSpec.hs b/test/InvariantSpec.hs new file mode 100644 --- /dev/null +++ b/test/InvariantSpec.hs @@ -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 diff --git a/test/THSpec.hs b/test/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/THSpec.hs @@ -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)