packages feed

invertible (empty) → 0.1

raw patch · 31 files changed

+1511/−0 lines, 31 filesdep +HListdep +Pisodep +TypeComposesetup-changed

Dependencies added: HList, Piso, TypeCompose, arrows, base, haskell-src-meta, invariant, lens, partial-isomorphisms, semigroupoids, template-haskell

Files

+ Control/Invertible/BiArrow.hs view
@@ -0,0 +1,177 @@+-- |+-- Bidirectional arrows.+-- Taken directly from+--+--  * Artem Alimarine, et al. /There and Back Again: Arrows for Invertible Programming/. Haskell '05. <http://citeseer.ist.psu.edu/alimarine05there.html>+--+{-# LANGUAGE CPP, Trustworthy #-}+module Control.Invertible.BiArrow+  ( BiArrow(..)+  , BiArrow'+  , biarr+  , involve+  , (^^>>)+  , (>>^^)+  , (<<^^)+  , (^^<<)+  ) where++import Prelude hiding ((.))++import Control.Arrow+import Control.Category++import Data.Invertible.Bijection+#ifdef VERSION_semigroupoids+import Data.Semigroupoid (Semigroupoid(..))+import Data.Groupoid (Groupoid(..))+import qualified Data.Isomorphism as Semigroupoid+#define SemigroupoidArrowA (Semigroupoid a, Arrow a)+#else+#define SemigroupoidArrowA Arrow a+#endif+#ifdef VERSION_TypeCompose+import qualified Data.Bijection as TypeCompose+#endif+#ifdef VERSION_partial_isomorphisms+import qualified Control.Isomorphism.Partial as Partial+import qualified Control.Isomorphism.Partial.Unsafe as Partial+#endif+#ifdef VERSION_arrows+import qualified Control.Arrow.Transformer.All as T+#endif++infix 2 <->++-- |The bidirectional arrow class.+--+-- Instances should satisfy the following laws:+--+--  * @f1 \<-\> g2 >>> g1 \<-\> f2 = (f1 >>> g1) \<-\> (f2 >>> g2)@+--  * @invert (invert f) = f@+--  * @invert (f \<-\> g) = g \<-\> f@+--  * @first (f \<-\> g) = f *** id \<-\> g *** id@+--  * @first h >>> id *** f \<-\> id *** g = id *** f \<-\> id *** g >>> first h@+--  * @first (first f) >>> assoc = assoc >>> first f@+--+-- where @assoc = ['Data.Invertible.TH.biCase'|((x,y),z) \<-\> (x,(y,z))|]@+class (+#ifdef VERSION_semigroupoids+    Groupoid a,+#endif+    Category a) => BiArrow a where+  -- |Take two functions and lift them into a bidirectional arrow.+  -- The intention is that these functions are each other's inverse.+  (<->) :: (b -> c) -> (c -> b) -> a b c+  -- |Inverse: reverse the direction of a bidirectional arrow.+  invert :: a b c -> a c b+#ifdef VERSION_semigroupoids+  invert = inv+#endif++-- |Bidirectional arrows under 'Arrow'.+--+-- Although 'BiArrow' should not, strictly speaking, be a subclass of 'Arrow' (as it is often impossible to define 'arr'), this is done because (as the paper says) \"conceptually bi-arrows form an extension of the arrow class. Moreover, it allows us to use bi-arrows as normal arrows.\"  This class exists to register this confound.+class (BiArrow a, Arrow a) => BiArrow' a++-- |Lift a bidirectional function to an arbitrary arrow using '<->'.+biarr :: BiArrow a => (b <-> c) -> a b c+biarr (f :<->: g) = f <-> g++-- |Construct an involution (a biarrow where the function and inverse are the same).+involve :: BiArrow a => (b -> b) -> a b b+involve f = f <-> f++infixr 1 ^^>>, >>^^+infixr 1 ^^<<, <<^^++-- | Precomposition with a pure bijection.+(^^>>) :: BiArrow a => (b <-> c) -> a c d -> a b d+f ^^>> a = biarr f >>> a++-- | Postcomposition with a pure bijection.+(>>^^) :: BiArrow a => a b c -> (c <-> d) -> a b d+a >>^^ f = a >>> biarr f++-- | Precomposition with a pure bijection (right-to-left variant).+(<<^^) :: BiArrow a => a c d -> (b <-> c) -> a b d+a <<^^ f = a <<< biarr f++-- | Postcomposition with a pure bijection (right-to-left variant).+(^^<<) :: BiArrow a => (c <-> d) -> a b c -> a b d+f ^^<< a = biarr f <<< a++instance SemigroupoidArrowA => BiArrow (Bijection a) where+  f <-> g = arr f :<->: arr g+  invert (f :<->: g) = g :<->: f++instance SemigroupoidArrowA => BiArrow' (Bijection a)++#ifdef VERSION_semigroupoids+instance (Semigroupoid a, Arrow a) => BiArrow (Semigroupoid.Iso a) where+  f <-> g = Semigroupoid.Iso (arr f) (arr g)+#endif++#ifdef VERSION_TypeCompose+#ifdef VERSION_semigroupoids+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid a => Semigroupoid (TypeCompose.Bijection a) where+  TypeCompose.Bi f1 g1 `o` TypeCompose.Bi f2 g2 = TypeCompose.Bi (o f1 f2) (o g2 g1)+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid a => Groupoid (TypeCompose.Bijection a) where+  inv = TypeCompose.inverse+#endif+instance SemigroupoidArrowA => BiArrow (TypeCompose.Bijection a) where+  f <-> g = TypeCompose.Bi (arr f) (arr g)+  invert = TypeCompose.inverse+instance SemigroupoidArrowA => BiArrow' (TypeCompose.Bijection a)+#endif++#ifdef VERSION_partial_isomorphisms+#ifdef VERSION_semigroupoids+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid Partial.Iso where+  o = (.)+-- |Poor orphans.  Please will someone adopt us?+instance Groupoid Partial.Iso where+  inv = Partial.inverse+#endif+instance BiArrow Partial.Iso where+  f <-> g = Partial.Iso (Just . f) (Just . g)+  invert = Partial.inverse+#endif++#ifdef VERSION_arrows+#ifdef VERSION_semigroupoids+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid a => Semigroupoid (T.StateArrow s a) where+  T.StateArrow f `o` T.StateArrow g = T.StateArrow (f `o` g)+-- |Poor orphans.  Please will someone adopt us?+instance Groupoid a => Groupoid (T.StateArrow s a) where+  inv (T.StateArrow f) = T.StateArrow (inv f)+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid a => Semigroupoid (T.CoStateArrow s a) where+  T.CoStateArrow f `o` T.CoStateArrow g = T.CoStateArrow (f `o` g)+-- |Poor orphans.  Please will someone adopt us?+instance Groupoid a => Groupoid (T.CoStateArrow s a) where+  inv (T.CoStateArrow f) = T.CoStateArrow (inv f)+-- |Poor orphans.  Please will someone adopt us?+instance Semigroupoid a => Semigroupoid (T.StreamArrow a) where+  T.StreamArrow f `o` T.StreamArrow g = T.StreamArrow (f `o` g)+-- |Poor orphans.  Please will someone adopt us?+instance Groupoid a => Groupoid (T.StreamArrow a) where+  inv (T.StreamArrow f) = T.StreamArrow (inv f)+#endif+instance (Arrow a, BiArrow a) => BiArrow (T.StateArrow s a) where+  f <-> g = T.StateArrow (first $ f <-> g)+  invert (T.StateArrow f) = T.StateArrow (invert f)+instance BiArrow' a => BiArrow' (T.StateArrow s a)+instance BiArrow a => BiArrow (T.CoStateArrow s a) where+  f <-> g = T.CoStateArrow ((f .) <-> (g .))+  invert (T.CoStateArrow f) = T.CoStateArrow (invert f)+instance BiArrow' a => BiArrow' (T.CoStateArrow s a)+instance BiArrow a => BiArrow (T.StreamArrow a) where+  f <-> g = T.StreamArrow (fmap f <-> fmap g)+  invert (T.StreamArrow f) = T.StreamArrow (invert f)+instance BiArrow' a => BiArrow' (T.StreamArrow a)+#endif
+ Control/Invertible/Functor.hs view
@@ -0,0 +1,46 @@+-- |+-- This provides a subset of the functionality as the invariant package's "Data.Functor.Invariant" module, but based on "Data.Invertible", without all the instances, and with an interface matching "Data.Functor".+--+-- This module is intended to be imported qualified, e.g.,:+-- +-- > import qualified Control.Invertible.Functor as Inv+--+{-# LANGUAGE CPP, Safe, FlexibleInstances #-}+module Control.Invertible.Functor+  ( Functor(..)+  , (<$>)+  ) where++import Prelude hiding ((.), Functor(..), (<$>))+import Control.Arrow (Arrow)+import Control.Category ((.))+import Data.Monoid (Endo(..))++#ifdef VERSION_semigroupoids+import Data.Semigroupoid (Semigroupoid)+#endif+import Control.Invertible.BiArrow ((^^<<), invert)+import Data.Invertible.Bijection+import Data.Invertible.Monoid (BiEndo(..))++-- |An invariant version of 'Data.Functor.Functor', equivalent to 'Data.Functor.Inviarant.Invariant'.+class Functor f where+  fmap :: a <-> b -> f a -> f b++-- |An infix synnonym for 'fmap'.+(<$>) :: Functor f => a <-> b -> f a -> f b+(<$>) = fmap+infixl 4 <$>++instance (+#ifdef VERSION_semigroupoids+    Semigroupoid a,+#endif+    Arrow a) => Functor (Bijection a b) where+  fmap = (^^<<)++instance Functor Endo where+  fmap (f :<->: g) (Endo a) = Endo $ f . a . g++instance Functor BiEndo where+  fmap f (BiEndo a) = BiEndo $ f . a . invert f
+ Control/Invertible/MonadArrow.hs view
@@ -0,0 +1,107 @@+-- |+-- A symmetric version of the Kleisli monad transformer arrow.+-- BiKleisli provides this Kleisli-like arrow over bijections.+--+-- The Alimarine paper just calls it \"MoT\" for Monad Transformer.+{-# LANGUAGE CPP, Safe, TupleSections, FlexibleInstances, FlexibleContexts #-}+module Control.Invertible.MonadArrow+  ( MonadArrow(..)+  , BiKleisli+  ) where++import Prelude hiding (id, (.))++import Control.Category+import Control.Arrow+import Control.Monad (MonadPlus(..))+#ifdef VERSION_semigroupoids+import Data.Semigroupoid (Semigroupoid(..))+import Data.Groupoid (Groupoid(..))+#endif++import Data.Invertible.Bijection+import Control.Invertible.BiArrow++-- |Bidirectional 'Control.Arrow.Kleisli'-like monad arrow transformer.+newtype MonadArrow a m b c = MonadArrow { runMonadArrow :: a (m b) (m c) }++-- |A MonadArrow over bijections.+type BiKleisli m a b = MonadArrow (<->) m a b++instance Category a => Category (MonadArrow a m) where+  id = MonadArrow id+  MonadArrow f . MonadArrow g = MonadArrow (f . g)++instance Monad m => Arrow (MonadArrow (->) m) where+  arr = MonadArrow . arr . fmap+  first  (MonadArrow f) = MonadArrow (>>= \ ~(a,c) -> ( ,c) <$> f (return a))+  second (MonadArrow f) = MonadArrow (>>= \ ~(a,b) -> (a, ) <$> f (return b))+  MonadArrow f *** MonadArrow g = MonadArrow+    (>>= \ ~(a,b) -> (,) <$> f (return a) <*> g (return b))+  MonadArrow f &&& MonadArrow g = MonadArrow+    (>>= \ a -> let ma = return a in (,) <$> f ma <*> g ma)++instance Monad m => ArrowChoice (MonadArrow (->) m) where+  left  (MonadArrow f) = MonadArrow (>>= either (fmap Left . f . return) (return . Right))+  right (MonadArrow f) = MonadArrow (>>= either (return . Left) (fmap Right . f . return))+  MonadArrow f +++ MonadArrow g = MonadArrow+    (>>= either (fmap Left . f . return) (fmap Right . g . return))+  MonadArrow f ||| MonadArrow g = MonadArrow+    (>>= either (f . return) (g . return))++instance MonadPlus m => ArrowZero (MonadArrow (->) m) where+  zeroArrow = MonadArrow (const mzero)++instance MonadPlus m => ArrowPlus (MonadArrow (->) m) where+  MonadArrow f <+> MonadArrow g = MonadArrow (>>= \x -> let mx = return x in f mx `mplus` g mx)++liftMoA :: (MonadArrow (->) m a b -> MonadArrow (->) m c d) -> (m a -> m b) -> (m c -> m d)+liftMoA t = runMonadArrow . t . MonadArrow++liftMoA2 :: (MonadArrow (->) m a b -> MonadArrow (->) m c d -> MonadArrow (->) m e f) -> (m a -> m b) -> (m c -> m d) -> (m e -> m f)+liftMoA2 t f g = runMonadArrow (MonadArrow f `t` MonadArrow g)++instance Monad m => Arrow (MonadArrow (<->) m) where+  arr = MonadArrow . arr . fmap+  first (MonadArrow (f :<->: g)) = MonadArrow $ bik f :<->: bik g+    where bik = liftMoA first+  second (MonadArrow (f :<->: g)) = MonadArrow $ bik f :<->: bik g+    where bik = liftMoA second+  MonadArrow (f :<->: g) *** MonadArrow (f' :<->: g') =+    MonadArrow $ bik f f' :<->: bik g g'+    where bik = liftMoA2 (***)+  MonadArrow (f :<->: g) &&& MonadArrow (f' :<->: _) =+    MonadArrow $ liftMoA2 (&&&) f f' :<->: (g . arr (fmap fst)) -- (g' . arr snd)++instance Monad m => ArrowChoice (MonadArrow (<->) m) where+  left  (MonadArrow (f :<->: g)) = MonadArrow $ bik f :<->: bik g+    where bik = liftMoA left+  right (MonadArrow (f :<->: g)) = MonadArrow $ bik f :<->: bik g+    where bik = liftMoA right+  MonadArrow (f :<->: g) +++ MonadArrow (f' :<->: g') =+    MonadArrow $ bik f f' :<->: bik g g'+    where bik = liftMoA2 (+++)+  MonadArrow (f :<->: g) ||| MonadArrow (f' :<->: _) =+    MonadArrow $ liftMoA2 (|||) f f' :<->: (arr (fmap Left) . g) -- (arr (fmap Right) . g)++instance MonadPlus m => ArrowZero (MonadArrow (<->) m) where+  zeroArrow = MonadArrow (const mzero :<->: const mzero)++instance MonadPlus m => ArrowPlus (MonadArrow (<->) m) where+  MonadArrow (f1 :<->: g1) <+> MonadArrow (f2 :<->: g2) =+    MonadArrow $ bik f1 f2 :<->: bik g1 g2+    where bik = liftMoA2 (<+>)++instance (BiArrow a, Monad m) => BiArrow (MonadArrow a m) where+  f <-> g = MonadArrow (arr (fmap f) <-> arr (fmap g))+  invert (MonadArrow f) = MonadArrow (invert f)++instance Monad m => BiArrow' (MonadArrow (<->) m)++#ifdef VERSION_semigroupoids+instance Semigroupoid a => Semigroupoid (MonadArrow a m) where+  MonadArrow f `o` MonadArrow g = MonadArrow (f `o` g)++instance Groupoid a => Groupoid (MonadArrow a m) where+  inv (MonadArrow f) = MonadArrow (inv f)+#endif
+ Control/Invertible/Monoidal.hs view
@@ -0,0 +1,142 @@+-- |+-- Invariant monoidal functors.+-- +-- This roughly corresponds to "Control.Applicative", but exposes a non-overlapping API so can be imported unqualified.  It does, however, use operators similar to those provided by contravariant.+{-# LANGUAGE CPP, Safe, FlexibleInstances #-}+module Control.Invertible.Monoidal+  ( -- * Functor+    (>$<)+  -- * Monoidal+  , Monoidal(..)+  , (>*), (*<)+  -- ** Tuple combinators+  , liftI2+  , liftI3+  , liftI4+  , liftI5+  , (>*<<)+  , (>*<<<)+  , (>*<<<<)+  , (>>*<)+  , (>>>*<)+  , (>>>>*<)+  , (>>*<<)+  , pureI+  , sequenceMaybesI+  , mapMaybeI+  -- * MonoidalAlt+  , MonoidalAlt(..)+  , possible+  , defaulting+  , while+  ) where++import Prelude+import Control.Arrow ((&&&), (***))++import Data.Invertible.Bijection+import qualified Data.Invertible as I++-- |Another synonym for 'fmap' to match other operators in this module.+(>$<) :: I.Functor f => a <-> b -> f a -> f b+(>$<) = I.fmap++infixl 4 >$<++-- |Lax invariant monoidal functor.+-- This roughly corresponds to 'Applicative', which, for covariant functors, is equivalent to a monoidal functor.+-- Invariant functors, however, may admit a monoidal instance but not applicative.+class I.Functor f => Monoidal f where+  -- |Lift a unit value, analogous to @'Control.Applicative.pure' ()@ (but also like @const ()@).+  unit :: f ()+  -- |Merge two functors into a tuple, analogous to @'Control.Applicative.liftA2' (,)@. (Sometimes known as @**@.)+  (>*<) :: f a -> f b -> f (a, b)++-- | Sequence actions, discarding/inhabiting the unit value of the first argument.+(*<) :: Monoidal f => f () -> f a -> f a+(*<) = liftI2 I.snd++-- | Sequence actions, discarding/inhabiting the unit value of the second argument.+(>*) :: Monoidal f => f a -> f () -> f a+(>*) = liftI2 I.fst++infixl 4 >*, >*<, *<++-- |Lift an (uncurried) bijection into a monoidal functor.+liftI2 :: Monoidal f => ((a, b) <-> c) -> f a -> f b -> f c+liftI2 f a b = f >$< (a >*< b)++liftI3 :: Monoidal f => ((a, b, c) <-> d) -> f a -> f b -> f c -> f d+liftI3 f a b c = f >$< (a >*< b >>*< c)++liftI4 :: Monoidal f => ((a, b, c, d) <-> e) -> f a -> f b -> f c -> f d -> f e+liftI4 f a b c d = f >$< (a >*< b >>*< c >>>*< d)++liftI5 :: Monoidal f => ((a, b, c, d, e) <-> g) -> f a -> f b -> f c -> f d -> f e -> f g+liftI5 f a b c d e = f >$< (a >*< b >>*< c >>>*< d >>>>*< e)++(>>*<) :: Monoidal f => f (a, b) -> f c -> f (a, b, c)+(>>*<) = liftI2 I.flatten2_1++(>>>*<) :: Monoidal f => f (a, b, c) -> f d -> f (a, b, c, d)+(>>>*<) = liftI2 I.flatten3_1++(>>>>*<) :: Monoidal f => f (a, b, c, d) -> f e -> f (a, b, c, d, e)+(>>>>*<) = liftI2 I.flatten4_1++infixl 4 >>*<, >>>*<, >>>>*<++(>*<<) :: Monoidal f => f a -> f (b, c) -> f (a, b, c)+(>*<<) = liftI2 I.flatten1_2++(>*<<<) :: Monoidal f => f a -> f (b, c, d) -> f (a, b, c, d)+(>*<<<) = liftI2 I.flatten1_3++(>*<<<<) :: Monoidal f => f a -> f (b, c, d, e) -> f (a, b, c, d, e)+(>*<<<<) = liftI2 I.flatten1_4++infixr 3 >*<<, >*<<<, >*<<<<++(>>*<<) :: Monoidal f => f (a, b) -> f (c, d) -> f (a, b, c, d)+(>>*<<) = liftI2 I.flatten2_2++infix 3 >>*<<++-- |A constant monoidal (like 'Control.Applicative.pure'), which always produces the same value and ignores everything.+pureI :: Monoidal f => a -> f a+pureI a = I.const a >$< unit++-- |Sequence (like 'Control.Applicative.sequenceA') and filter (like 'Data.Maybe.catMaybes') a list of monoidals, producing the list of non-'Nothing' values.+-- Shorter input lists pad with 'Nothing's and longer ones are ignored.+sequenceMaybesI :: Monoidal f => [f (Maybe a)] -> f [a]+sequenceMaybesI [] = pureI []+sequenceMaybesI (x:l) = liftI2 I.consMaybe x (sequenceMaybesI l)++-- |Map each element to a 'Maybe' monoidal and sequence the results (like 'Control.Applicative.traverse' and 'Data.Maybe.mapMaybe').+mapMaybeI :: Monoidal f => (a -> f (Maybe b)) -> [a] -> f [b]+mapMaybeI = (sequenceMaybesI .) . map++-- |Monoidal functors that allow choice.+class Monoidal f => MonoidalAlt f where+  -- |Associative binary choice.+  (>|<) :: f a -> f b -> f (Either a b)++infixl 3 >|<++-- |Analogous to 'Control.Applicative.optional'.+possible :: MonoidalAlt f => f a -> f (Maybe a)+possible f = I.lft >$< (f >|< unit)++-- |Return a default value if a monoidal functor fails, and only apply it to non-default values.+defaulting :: (MonoidalAlt f, Eq a) => a -> f a -> f a+defaulting a f = I.fromMaybe a >$< possible f++-- |Repeatedly apply a monoidal functor until it fails.  Analogous to 'Control.Applicative.many'.+while :: MonoidalAlt f => f a -> f [a]+while f = I.cons >$< possible (f >*< while f)+++instance Monoidal (Bijection (->) ()) where+  unit = I.id+  -- |Uses the 'Monoid' instance to combine '()'s.+  (ua :<->: au) >*< (ub :<->: bu) = ua &&& ub :<->: uncurry mappend . (au *** bu)
+ Control/Invertible/Monoidal/HList.hs view
@@ -0,0 +1,35 @@+-- |+-- Combine monoidal functors into HLists.+{-# LANGUAGE DataKinds, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeFamilies, UndecidableInstances #-}+module Control.Invertible.Monoidal.HList+  ( hConsI+  , (>:*<)+  , HSequenceI(..)+  ) where++import Prelude hiding (Functor(..), (<$>), fst, snd, id)+import qualified Data.HList as HL++import Data.Invertible.HList+import Control.Invertible.Monoidal++-- |'HL.HCons' two monoidal functors.+hConsI :: Monoidal f => f a -> f (HL.HList l) -> f (HL.HList (a ': l))+hConsI = liftI2 hCons++-- |Infix alias for 'hConsI'.+(>:*<) :: Monoidal f => f a -> f (HL.HList l) -> f (HL.HList (a ': l))+(>:*<) = hConsI++infixr 4 >:*<++-- |A monoidal version of 'HL.HSequence': a heteogeneous version of 'sequenceMaybesI'.+class (Monoidal m, HL.SameLength a b) => HSequenceI m a b | a -> b, m b -> a where+  hSequenceI :: HL.HList a -> m (HL.HList b)++instance Monoidal m => HSequenceI m '[] '[] where+  hSequenceI _ = pureI HL.HNil++instance (m1 ~ m, Monoidal m, HSequenceI m as bs) => HSequenceI m (m1 a ': as) (a ': bs) where+  hSequenceI (HL.HCons a b) = a >:*< hSequenceI b+
+ Data/Invertible.hs view
@@ -0,0 +1,45 @@+-- |+-- Bidirectional functions.+-- The type 'Data.Invertible.Bijection.<->' is the basis, representing a bijective function between two types.+-- Bijections can be constructed from two functions with 'Control.Invertible.BiArrow.<->' or from a set of Haskell cases using 'biCase'.+--+-- This and other modules in this package export functionality generally mirroring that provided by the base modules, but over bijections.  They are thus intended to be imported qualified, e.g.,:+-- +-- > import qualified Data.Invertible as Inv+--+{-# LANGUAGE Safe #-}+module Data.Invertible+  ( module Data.Invertible.Bijection+  , module Data.Invertible.TH+  , module Data.Invertible.Prelude+  , module Data.Invertible.Bits+  , module Data.Invertible.Bool+  , module Data.Invertible.Complex+  , module Data.Invertible.Either+  , module Data.Invertible.Function+  , module Data.Invertible.Functor+  , module Data.Invertible.List+  , module Data.Invertible.Maybe+  , module Data.Invertible.Monoid+  , module Data.Invertible.Ord+  , module Data.Invertible.Tuple+  , module Control.Invertible.BiArrow+  , module Control.Invertible.Functor+  ) where++import Data.Invertible.Bijection+import Data.Invertible.TH+import Data.Invertible.Prelude+import Data.Invertible.Bits+import Data.Invertible.Bool+import Data.Invertible.Complex+import Data.Invertible.Either+import Data.Invertible.Function+import Data.Invertible.Functor+import Data.Invertible.List+import Data.Invertible.Maybe+import Data.Invertible.Monoid+import Data.Invertible.Ord+import Data.Invertible.Tuple+import Control.Invertible.BiArrow+import Control.Invertible.Functor
+ Data/Invertible/Bijection.hs view
@@ -0,0 +1,77 @@+-- |+-- The base representation for bidirectional arrows (bijections).+{-# LANGUAGE Trustworthy, KindSignatures, FlexibleInstances, CPP #-}+module Data.Invertible.Bijection+  ( Bijection(..)+  , type (<->)+  ) where++import Prelude hiding (id, (.))+import Control.Category+import Control.Arrow+#ifdef VERSION_semigroupoids+import Data.Semigroupoid (Semigroupoid(..))+import Data.Groupoid (Groupoid(..))+#endif+#ifdef VERSION_invariant+import Data.Functor.Invariant (Invariant(..), Invariant2(..))+#endif++infix 2 <->, :<->:++-- |A representation of a bidirectional arrow (embedding-projection pair of arrows transformer): an arrow and its inverse.+-- Most uses will prefer the specialized '<->' type for function arrows.+--+-- To constitute a valid bijection, 'biTo' and 'biFrom' should be inverses:+--+--  * @biTo . biFrom = id@+--  * @biFrom . biTo = id@+--+-- It may be argued that the arguments should be in the opposite order due to the arrow syntax, but it makes more sense to me to have the forward function come first.+data Bijection (a :: * -> * -> *) b c = (:<->:)+  { biTo :: a b c+  , biFrom :: a c b+  }++-- |Specialization of 'Bijection' to function arrows.+-- Represents both a function, @f@, and its (presumed) inverse, @g@, represented as @f ':<->:' g@.+type (<->) = Bijection (->)++instance Category a => Category (Bijection a) where+  id = id :<->: id+  (f1 :<->: g1) . (f2 :<->: g2) = f1 . f2 :<->: g2 . g1++-- |In order to use all the 'Arrow' functions, we make a partially broken instance, where 'arr' creates a bijection with a broken 'biFrom'. See note on 'Control.Invertible.BiArrow.BiArrow''.+-- '&&&' is first-biased, and uses only the left argument's 'biFrom'.+instance Arrow a => Arrow (Bijection a) where+  arr f = arr f :<->: arr (const (error "Bijection: arr has no inverse"))+  first  (f :<->: g) = first f  :<->: first g+  second (f :<->: g) = second f :<->: second g+  (f :<->: g) *** (f' :<->: g') = (f *** f') :<->: (g *** g')+  (f :<->: g) &&& (f' :<->: _ ) = (f &&& f') :<->: (g . arr fst) -- (g' . arr snd)++-- |'|||' is Left-biased, and uses only the left argument's 'biFrom'.+instance ArrowChoice a => ArrowChoice (Bijection a) where+  left  (f :<->: g) = left f  :<->: left g+  right (f :<->: g) = right f :<->: right g+  (f :<->: g) +++ (f' :<->: g') = (f +++ f') :<->: (g +++ g')+  (f :<->: g) ||| (f' :<->: _ ) = (f ||| f') :<->: (arr Left . g) -- (arr Right . g')++instance ArrowZero a => ArrowZero (Bijection a) where+  zeroArrow = zeroArrow :<->: zeroArrow++#ifdef VERSION_semigroupoids+instance Semigroupoid a => Semigroupoid (Bijection a) where+  (f1 :<->: g1) `o` (f2 :<->: g2) = (f1 `o` f2) :<->: (g2 `o` g1)++instance Semigroupoid a => Groupoid (Bijection a) where+  inv (f :<->: g) = g :<->: f+#endif++#ifdef VERSION_invariant+instance Invariant (Bijection (->) b) where+  invmap = ((.) .) . (:<->:)++instance Invariant2 (Bijection (->)) where+  invmap2 f g = (.) ((. (g :<->: f)) .) . invmap+#endif
+ Data/Invertible/Bits.hs view
@@ -0,0 +1,15 @@+-- |+-- Bidirectional version of "Data.Bits".+{-# LANGUAGE Safe #-}+module Data.Invertible.Bits+  ( complement+  ) where++import qualified Data.Bits as B++import Data.Invertible.Bijection+import Data.Invertible.Internal++-- |'B.complement' all the bits in the argument.+complement :: B.Bits a => a <-> a+complement = involution B.complement
+ Data/Invertible/Bool.hs view
@@ -0,0 +1,16 @@+-- |+-- Bidirectional version of "Data.Bool".+{-# LANGUAGE Safe #-}+module Data.Invertible.Bool+  ( not+  ) where++import Prelude hiding (not)+import qualified Data.Bool as B++import Data.Invertible.Bijection+import Data.Invertible.Internal++-- |Boolean 'B.not'.+not :: Bool <-> Bool+not = involution B.not
+ Data/Invertible/Coerce.hs view
@@ -0,0 +1,13 @@+-- |+-- Bidirectional version of "Data.Coerce".+module Data.Invertible.Coerce+  ( coerce+  ) where++import qualified Data.Coerce as C++import Data.Invertible.Bijection++-- |Safely 'C.coerce' between values of types that have the same representation.+coerce :: (C.Coercible a b, C.Coercible b a) => a <-> b+coerce = C.coerce :<->: C.coerce
+ Data/Invertible/Complex.hs view
@@ -0,0 +1,26 @@+-- |+-- Bidirectional version of "Data.Complex".+{-# LANGUAGE Safe #-}+module Data.Invertible.Complex+  ( complex+  , polar+  , conjugate+  ) where++import qualified Data.Complex as C++import Data.Invertible.Bijection+import Data.Invertible.Internal+import Data.Invertible.TH++-- |Convert between 'Complex' numbers and rectangular form.+complex :: (a, a) <-> C.Complex a+complex = [biCase|(r, i) <-> r C.:+ i|]++-- |Convert between complex numbers and 'C.polar' form.+polar :: RealFloat a => (a, a) <-> C.Complex a+polar = uncurry C.mkPolar :<->: C.polar++-- |The 'C.conjugate' of a complex number.+conjugate :: Num a => C.Complex a <-> C.Complex a+conjugate = involution C.conjugate
+ Data/Invertible/Either.hs view
@@ -0,0 +1,55 @@+-- |+-- Bidirectional version of "Data.Either".+{-# LANGUAGE Safe #-}+module Data.Invertible.Either+  ( switch+  , isLeft+  , isRight+  , lft+  , rgt+  ) where++import Prelude++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |Convert between 'Left' and 'Right'.+switch :: Either a b <-> Either b a+switch =+  [biCase|+    Left a <-> Right a+    Right a <-> Left a+  |]++-- |Convert between 'Left' and 'True' (see 'Data.Either.isLeft').+isLeft :: Either () () <-> Bool+isLeft =+  [biCase|+    Left () <-> True+    Right () <-> False+  |]++-- |Convert between 'Right' and 'True' (see 'Data.Either.isRight'). (@'Data.Invertible.Bool.not' . 'isLeft'@) +isRight :: Either () () <-> Bool+isRight =+  [biCase|+    Right () <-> True+    Left () <-> False+  |]++-- |Convert between 'Left' and 'Just'.+lft :: Either a () <-> Maybe a+lft =+  [biCase|+    Left a <-> Just a+    Right () <-> Nothing+  |]++-- |Convert between 'Right and 'Just'.+rgt :: Either () a <-> Maybe a+rgt =+  [biCase|+    Left () <-> Nothing+    Right a <-> Just a+  |]
+ Data/Invertible/Function.hs view
@@ -0,0 +1,37 @@+-- |+-- Bidirectional version of "Data.Function".+{-# LANGUAGE Safe #-}+module Data.Invertible.Function+  ( id+  , (.)+  , consts+  , const+  , flip+  ) where++import Prelude hiding (id, (.), const, flip)+import qualified Control.Category as C+import qualified Data.Function as F++import Data.Invertible.Bijection++-- |Identity bijection.+id :: a <-> a+id = C.id++-- |Bijection composition+(.) :: (b <-> c) -> (a <-> b) -> a <-> c+(.) = (C..)+infixr 9 .++-- |Bidirectional constant function (not a true bijection).+consts :: a -> b -> a <-> b+consts a b = F.const b :<->: F.const a++-- |Convert between '()' and a constant (not a true bijection).+const :: a -> () <-> a+const = consts ()++-- |'F.flip' the order of the first two arguments of a function.+flip :: (a -> b -> c) <-> (b -> a -> c)+flip = F.flip :<->: F.flip
+ Data/Invertible/Functor.hs view
@@ -0,0 +1,23 @@+-- |+-- Bidirectional version of "Data.Functor".+{-# LANGUAGE Safe #-}+module Data.Invertible.Functor+  ( bifmap+  , identity+  ) where++import Prelude hiding (fmap, (<$>))+import qualified Data.Functor as F+import Data.Functor.Identity (Identity(..))++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |Lift both sides of an bijection over a functor using 'F.fmap'.+-- We name this bifmap in deference to the more useful 'Control.Invertible.Functor.fmap'.+bifmap :: Functor f => a <-> b -> f a <-> f b+bifmap (f :<->: g) = F.fmap f :<->: F.fmap g++-- |Convert the 'Identity' functor.+identity :: a <-> Identity a+identity = [biCase|a <-> Identity a|]
+ Data/Invertible/HList.hs view
@@ -0,0 +1,36 @@+-- |+-- Bidirectional version of "Data.HList.HList".+{-# LANGUAGE DataKinds, FlexibleContexts #-}+module Data.Invertible.HList+  ( hCons+  , hReverse+  , hReverse_+  , hAppend+  , hZip+  ) where++import qualified Data.HList as HL+import Data.Proxy (Proxy(..))++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |(De)construct an list from a head and tail.+hCons :: (a, HL.HList l) <-> HL.HList (a ': l)+hCons = [biCase|(a, l) <-> HL.HCons a l|]++-- |'HL.hReverse' the order of a list.+hReverse :: (HL.HReverse a b, HL.HReverse b a) => HL.HList a <-> HL.HList b+hReverse = HL.hReverse :<->: HL.hReverse++-- |'HL.hReverse_' the order of a list.+hReverse_ :: (HL.HRevApp a '[] b, HL.HRevApp b '[] a) => HL.HList a <-> HL.HList b+hReverse_ = HL.hReverse_ :<->: HL.hReverse_++-- |'HL.hAppend' (concatenate) or split two lists.+hAppend :: (HL.HAppendList a b, HL.HSplitAt n (HL.HAppendListR a b) a b) => (HL.HList a, HL.HList b) <-> HL.HList (HL.HAppendListR a b)+hAppend = uncurry HL.hAppendList :<->: HL.hSplitAt Proxy++-- |'HL.hZip' two lists together.+hZip :: HL.HZipList a b l => (HL.HList a, HL.HList b) <-> HL.HList l+hZip = uncurry HL.hZipList :<->: HL.hUnzipList
+ Data/Invertible/Internal.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Safe #-}+module Data.Invertible.Internal+  ( invert+  , involution+  ) where++import Data.Invertible.Bijection++-- |Invert an isomorphism by exchanging the two arrows (same as 'Control.Invertible.BiArrow.invert').+invert :: Bijection a b c -> Bijection a c b+invert (f :<->: g) = g :<->: f+{-# INLINE invert #-}++-- |Construct an involution (an bijection where the function and inverse are the same) (overlaps with 'Control.Invertible.BiArrow.involve').+involution :: a b b -> Bijection a b b+involution f = f :<->: f+{-# INLINE involution #-}
+ Data/Invertible/Invariant.hs view
@@ -0,0 +1,12 @@+-- |+-- Use bijections on 'Invariant' functors from "Data.Functor.Invariant".+module Data.Invertible.Invariant+  ( invmap+  ) where++import Data.Invertible.Bijection+import qualified Data.Functor.Invariant as I++-- |Apply a bijection over an 'I.Invariant' using 'I.invmap'.+invmap :: I.Invariant f => a <-> b -> f a -> f b+invmap (f :<->: g) = I.invmap f g
+ Data/Invertible/Lens.hs view
@@ -0,0 +1,18 @@+-- |+-- Convert bijections to and from lens isomorphisms in "Control.Lens.Iso".+{-# LANGUAGE RankNTypes #-}+module Data.Invertible.Lens+  ( toIso+  , unIso+  ) where++import Data.Invertible.Bijection+import qualified Control.Lens.Iso as L++-- |Convert an isomorphism to a lens.+toIso :: a <-> b -> L.Iso' a b+toIso (f :<->: g) = L.iso f g++-- |Convert a lens to an isomorphism.+unIso :: L.AnIso' a b -> a <-> b+unIso l = L.withIso l (:<->:)
+ Data/Invertible/List.hs view
@@ -0,0 +1,111 @@+-- |+-- Bidirectional version of "Data.List" and other operations over lists.+{-# LANGUAGE Safe #-}+module Data.Invertible.List+  ( cons+  , uncons+  , consMaybe+  , repLen+  , map+  , reverse+  , transpose+  , zip+  , zip3+  , zip4+  , zip5+  , zip6+  , zip7+  , zipWith+  , interleave+  , lines+  , words+  ) where++import Prelude hiding (map, reverse, zip, zip3, unzip, zipWith, lines, words)+import Control.Arrow ((***))+import qualified Data.List as L++import Data.Invertible.Bijection+import Data.Invertible.TH+import Data.Invertible.Internal++-- |Convert between @'Just' (head, tail)@ and the non-empty list @head:tail@.+cons :: Maybe (a, [a]) <-> [a]+cons =+  [biCase|+    Just (a, l) <-> a:l+    Nothing <-> []+  |]++-- |Convert between the non-empty list @head:tail@ and @'Just' (head, tail)@. (@'Control.Invertible.BiArrow.invert' 'cons'@)+uncons :: [a] <-> Maybe (a, [a])+uncons = invert cons++-- |Convert between @('Just' head, tail)@ and the non-empty list @head:tail@, or @('Nothing', list)@ and @list@.+consMaybe :: (Maybe a, [a]) <-> [a]+consMaybe =+  [biCase|+    (Just a, l) <-> a:l+    (Nothing, l) <-> l+  |]++-- |Combine 'L.replicate' and 'L.length' for unit lists.+repLen :: Int <-> [()]+repLen = (`L.replicate` ()) :<->: L.length++-- |Apply a bijection over a list using 'L.map'.+map :: (a <-> b) -> [a] <-> [b]+map (f :<->: g) = L.map f :<->: L.map g++-- |'L.reverse' the order of a (finite) list.+reverse :: [a] <-> [a]+reverse = involution L.reverse++-- |'L.transpose' the rows and columns of its argument.+transpose :: [[a]] <-> [[a]]+transpose = involution L.transpose++-- |'L.zip' two lists together.+zip :: ([a], [b]) <-> [(a, b)]+zip = uncurry L.zip :<->: L.unzip++-- |'L.zip3' three lists together.+zip3 :: ([a], [b], [c]) <-> [(a, b, c)]+zip3 = (\(a,b,c) -> L.zip3 a b c) :<->: L.unzip3++-- |'L.zip4' four lists together.+zip4 :: ([a], [b], [c], [d]) <-> [(a, b, c, d)]+zip4 = (\(a,b,c,d) -> L.zip4 a b c d) :<->: L.unzip4++-- |'L.zip5' five lists together.+zip5 :: ([a], [b], [c], [d], [e]) <-> [(a, b, c, d, e)]+zip5 = (\(a,b,c,d,e) -> L.zip5 a b c d e) :<->: L.unzip5++-- |'L.zip6' six lists together.+zip6 :: ([a], [b], [c], [d], [e], [f]) <-> [(a, b, c, d, e, f)]+zip6 = (\(a,b,c,d,e,f) -> L.zip6 a b c d e f) :<->: L.unzip6++-- |'L.zip7' seven lists together.+zip7 :: ([a], [b], [c], [d], [e], [f], [g]) <-> [(a, b, c, d, e, f, g)]+zip7 = (\(a,b,c,d,e,f,g) -> L.zip7 a b c d e f g) :<->: L.unzip7++-- |'L.zipWith' two lists together using a bijection.+zipWith :: (a, b) <-> c -> ([a], [b]) <-> [(c)]+zipWith (f :<->: g) = uncurry (L.zipWith (curry f)) :<->: L.unzip . L.map g++-- |(Un)interleave two lists, e.g., between @([2,5,11],[3,7])@ and @[2,3,5,7,11]@.+interleave :: ([a], [a]) <-> [a]+interleave = uncurry f :<->: g where+  f (x:xl) (y:yl) = x:y:f xl yl+  f [] l = l+  f l [] = l+  g (x:y:l) = (x:) *** (y:) $ g l +  g l = (l, [])++-- |Split a string into 'L.lines'.+lines :: String <-> [String]+lines = L.lines :<->: L.unlines++-- |Split a string into 'L.words'.+words :: String <-> [String]+words = L.words :<->: L.unwords
+ Data/Invertible/Maybe.hs view
@@ -0,0 +1,44 @@+-- |+-- Bidirectional version of "Data.Maybe".+{-# LANGUAGE Safe #-}+module Data.Invertible.Maybe+  ( isJust+  , isNothing+  , listToMaybe+  , maybeToList+  , fromMaybe+  ) where++import qualified Data.Maybe as M++import Data.Invertible.Bijection+import Data.Invertible.TH+import Data.Invertible.Internal++-- |Convert between 'Just ()' and 'True' (see 'M.isJust').+isJust :: Maybe () <-> Bool+isJust =+  [biCase|+    Just () <-> True+    Nothing <-> False+  |]++-- |Convert between 'Nothing' and 'True' (see 'M.isNothing'). (@'Data.Invertible.Bool.not' . 'isJust'@)+isNothing :: Maybe () <-> Bool+isNothing = +  [biCase|+    Nothing <-> True+    Just () <-> False+  |]++-- |Convert between (the head of) a (singleton) list and 'Maybe' (see 'M.listToMaybe'). (@'Control.Invertible.BiArrow.inv' 'maybeToList'@)+listToMaybe :: [a] <-> Maybe a+listToMaybe = M.listToMaybe :<->: M.maybeToList++-- |Convert between 'Maybe' and a (singleton) list (see 'M.maybeToList'). (@'Control.Invertible.BiArrow.inv' 'listToMaybe'@)+maybeToList :: Maybe a <-> [a]+maybeToList = invert listToMaybe++-- |Convert between 'Nothing' and a default value, or 'Just' and its value (not a true bijection).+fromMaybe :: Eq a => a -> Maybe a <-> a+fromMaybe d = M.fromMaybe d :<->: \a -> if a == d then Nothing else Just a
+ Data/Invertible/Monoid.hs view
@@ -0,0 +1,71 @@+-- |+-- Bidirectional transforms for "Data.Monoid".+{-# LANGUAGE Safe #-}+module Data.Invertible.Monoid+  ( BiEndo(..)+  , dual+  , endo+  , biEndo+  , all+  , any+  , sum+  , product+  , first+  , last+  , alt+  ) where++import Prelude hiding (fmap, (<$>), all, any, sum, product, last)+import qualified Control.Category as C+import Data.Monoid++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |(Un)wrap the 'Dual' monoid.+dual :: a <-> Dual a+dual = [biCase|a <-> Dual a|]++-- |(Un)wrap the 'Endo' monoid.+endo :: (a -> a) <-> Endo a+endo = [biCase|a <-> Endo a|]++-- | The monoid of endomorphisms under composition.+newtype BiEndo a = BiEndo { appBiEndo :: a <-> a }++instance Monoid (BiEndo a) where+  mempty = BiEndo C.id+  BiEndo f `mappend` BiEndo g = BiEndo (f C.. g)++-- |(Un)wrap the 'BiEndo' monoid.+biEndo :: (a <-> a) <-> BiEndo a+biEndo = [biCase|a <-> BiEndo a|]++-- |(Un)wrap the 'All' monoid.+all :: Bool <-> All+all = [biCase|a <-> All a|]++-- |(Un)wrap the 'Any' monoid.+any :: Bool <-> Any+any = [biCase|a <-> Any a|]++-- |(Un)wrap the 'Sum' monoid.+sum :: a <-> Sum a+sum = [biCase|a <-> Sum a|]++-- |(Un)wrap the 'Product' monoid.+product :: a <-> Product a+product = [biCase|a <-> Product a|]++-- |(Un)wrap the 'First' monoid.+first :: Maybe a <-> First a+first = [biCase|a <-> First a|]++-- |(Un)wrap the 'Last' monoid.+last :: Maybe a <-> Last a+last = [biCase|a <-> Last a|]++-- |(Un)wrap the 'Last' monoid.+alt :: f a <-> Alt f a+alt = [biCase|a <-> Alt a|]+
+ Data/Invertible/Ord.hs view
@@ -0,0 +1,18 @@+-- |+-- Bidirectional operations over 'Ordering'.+{-# LANGUAGE Safe #-}+module Data.Invertible.Ord+  ( down+  ) where++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |Invert an 'Ordering' (see 'Data.Ord.Down').+down :: Ordering <-> Ordering+down =+  [biCase|+    LT <-> GT+    EQ <-> EQ+    GT <-> LT+  |]
+ Data/Invertible/PartialIsomorphism.hs view
@@ -0,0 +1,25 @@+-- |+-- Convert bijections to and from (total) 'P.Iso'.+module Data.Invertible.PartialIsomorphism+  ( toIso+  , fromIso+  , (<$>)+  ) where++import Prelude hiding ((<$>))++import Data.Invertible.Bijection+import qualified Control.Isomorphism.Partial as P+import qualified Control.Isomorphism.Partial.Unsafe as P++-- |Convert a bijection to a (total) partial isomorphism.+toIso :: a <-> b -> P.Iso a b+toIso (f :<->: g) = P.Iso (Just . f) (Just . g)++-- |Convert a partial isomorphism to a bijection by propagating 'Nothing's.+fromIso :: P.Iso a b -> Maybe a <-> Maybe b+fromIso (P.Iso f g) = (f =<<) :<->: (g =<<)++-- |Apply a bijection over a 'P.IsoFunctor' using 'P.<$>'.+(<$>) :: P.IsoFunctor f => a <-> b -> f a -> f b+(<$>) = (P.<$>) . toIso
+ Data/Invertible/Piso.hs view
@@ -0,0 +1,17 @@+-- |+-- Convert bijections to and from (total) 'P.Piso'.+module Data.Invertible.Piso+  ( toPiso+  , fromPiso+  ) where++import Data.Invertible.Bijection+import qualified Data.Piso as P++-- |Convert a bijection to a (total) partial isomorphism.+toPiso :: a <-> b -> P.Piso a b+toPiso (f :<->: g) = P.Piso f (Just . g)++-- |Convert a partial isomorphism to a total bijection using a default value for the failure case.+fromPiso :: b -> P.Piso a b -> Maybe a <-> b+fromPiso b (P.Piso f g) = maybe b f :<->: g
+ Data/Invertible/Prelude.hs view
@@ -0,0 +1,46 @@+-- |+-- The bidirectional \"Prelude\", which re-exports various bijections similar to functions from "Prelude".+-- Most \"un\"-functions are left out for obvious reasons.+{-# LANGUAGE Safe #-}+module Data.Invertible.Prelude+  ( (<->)+  , type (<->)++  , enum++  , const+  , flip+  , id+  , (.)+  , not+  , fst+  , snd+  , curry+  , cons+  , uncons+  , bifmap+  , Functor(..)+  , (<$>)+  , map+  , reverse+  , zip+  , zip3+  , zipWith+  , lines+  , words+  ) where++import Prelude hiding (not, id, (.), const, flip, Functor(..), (<$>), fst, snd, curry, uncurry, map, reverse, zip, zip3, unzip, zipWith, lines, words)++import Control.Invertible.BiArrow+import Control.Invertible.Functor+import Data.Invertible.Bijection+import Data.Invertible.Bool+import Data.Invertible.Function+import Data.Invertible.Functor+import Data.Invertible.Tuple+import Data.Invertible.List++-- |Convert between an 'Int' and an 'Enum' with 'P.toEnum' and 'P.fromEnum'.+enum :: Enum a => Int <-> a+enum = toEnum :<->: fromEnum
+ Data/Invertible/Semigroupoid.hs view
@@ -0,0 +1,17 @@+-- |+-- Convert bijections to and from semigroupoids 'S.Iso'.+module Data.Invertible.Semigroupoid+  ( toIso+  , fromIso+  ) where++import Data.Invertible.Bijection+import qualified Data.Isomorphism as S++-- |Convert a bijection to a semigroupoid isomorphism.+toIso :: Bijection a b c -> S.Iso a b c+toIso (f :<->: g) = S.Iso f g++-- |Convert a semigroupoid isomorphism to a bijection.+fromIso :: S.Iso a b c -> Bijection a b c+fromIso (S.Iso f g) = f :<->: g
+ Data/Invertible/TH.hs view
@@ -0,0 +1,90 @@+-- |+-- Convenient construction of bidirectional functions using case-like syntax.+{-# LANGUAGE TemplateHaskell, Trustworthy #-}+module Data.Invertible.TH+  ( biCase+  ) where++import Control.Arrow (second)+import Control.Monad (liftM2)+import Data.Char (isSpace)+import Data.Data (Data, gmapT)+import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Tuple (swap)+import Data.Typeable (cast)+import Language.Haskell.Meta.Parse (parsePat)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import Data.Invertible.Bijection++split :: Eq a => [a] -> [a] -> [[a]]+split _ [] = []+split t s@(c:r)+  | Just s' <- stripPrefix t s = [] : split t s'+  | p:l <- split t r = (c:p):l+  | otherwise = [s]++patToPat :: TH.Pat -> TH.Pat+patToPat = ptp . gmapT pta where+  pta :: Data a => a -> a+  pta = fromMaybe id $ cast patToPat+  ptp (TH.ViewP e p) = TH.ViewP (TH.VarE 'biTo `TH.AppE` e) p+  ptp p = p++patToExp :: TH.Pat -> TH.Exp+patToExp (TH.LitP l) = TH.LitE l+patToExp (TH.VarP v) = TH.VarE v+patToExp (TH.TupP l) = TH.TupE $ map patToExp l+patToExp (TH.UnboxedTupP l) = TH.UnboxedTupE $ map patToExp l+patToExp (TH.ConP c a) = foldl (\f -> TH.AppE f . patToExp) (TH.ConE c) a+patToExp (TH.InfixP l o r) = TH.InfixE (Just $ patToExp l) (TH.ConE o) (Just $ patToExp r)+patToExp (TH.UInfixP l o r) = TH.UInfixE (patToExp l) (TH.ConE o) (patToExp r)+patToExp (TH.ParensP p) = TH.ParensE $ patToExp p+patToExp (TH.TildeP p) = patToExp p+patToExp (TH.BangP p) = patToExp p+patToExp (TH.AsP _ p) = patToExp p+patToExp TH.WildP = TH.VarE 'undefined+patToExp (TH.RecP c f) = TH.RecConE c $ map (second patToExp) f+patToExp (TH.ListP l) = TH.ListE $ map patToExp l+patToExp (TH.SigP p t) = TH.SigE (patToExp p) t+patToExp (TH.ViewP e p) = TH.VarE 'biFrom `TH.AppE` e `TH.AppE` patToExp p++parseP :: String -> TH.PatQ+parseP s = either (fail . (++) ("Failed to parse pattern '" ++ s ++ "': ")) return $ parsePat s++biExp :: String -> TH.ExpQ+biExp = fmap ie . mapM ic . filter (not . all isSpace) . concatMap (split ";") . lines where+  ie l = TH.InfixE (Just $ ce l) (TH.ConE '(:<->:)) (Just $ ce $ map swap l)+  ce [(p, e)] = TH.LamE [patToPat p] $ patToExp e+  ce l = TH.LamCaseE [ TH.Match (patToPat p) (TH.NormalB $ patToExp e) [] | (p, e) <- l ]+  ic s+    | [fs, gs] <- split "<->" s =+      liftM2 (,) (parseP fs) (parseP gs)+    | otherwise = fail "each bijection case must contain exactly one '<->'"++-- |Construct an expression representing a function bijection based on a set of newline- or semicolon-separated cases.+-- Each case should be two pattern-expressions separated by @<->@.+-- Each pattern-expression is a haskell pattern that can also be interpreted as an expression.+-- You can think of these as symmetric or bidirectional case expressions.+-- The result will be a bijection that is the combination of two lambdas, one with the cases intepreted forward, and one reverse.+-- For example:+--+-- > newtype T a = C a+-- > biC :: T a <-> a+-- > biC = [biCase| C a <-> a |]+--+-- > isJust :: Maybe () <-> Bool+-- > isJust = [biCase|+-- >     Just () <-> True+-- >     Nothing <-> False+-- >   |]+-- +biCase :: QuasiQuoter+biCase = QuasiQuoter+  { quoteExp = biExp+  , quoteType = const $ fail "biCase not supported in types"+  , quotePat = const $ fail "biCase not supported in patterns"+  , quoteDec = const $ fail "biCase not supported in declarations"+  }
+ Data/Invertible/Tuple.hs view
@@ -0,0 +1,59 @@+-- |+-- Bidirectional version of "Data.Tuple" and other operations over nested tuples.+{-# LANGUAGE Safe #-}+module Data.Invertible.Tuple+  ( fst+  , snd+  , curry+  , swap+  , flatten1_2+  , flatten1_3+  , flatten1_4+  , flatten2_1+  , flatten2_2+  , flatten3_1+  , flatten4_1+  ) where++import Prelude hiding (fst, snd, curry, uncurry)+import qualified Data.Tuple as T++import Data.Invertible.Bijection+import Data.Invertible.TH++-- |Extract the 'T.fst' component of a pair.+fst :: (a, ()) <-> a+fst = [biCase|(a, ()) <-> a|]++-- |Extract the 'T.snd' component of a pair.+snd :: ((), a) <-> a+snd = [biCase|((), a) <-> a|]++-- |Convert between an uncurried function and a 'T.curry'ed function.+curry :: ((a, b) -> c) <-> (a -> b -> c)+curry = T.curry :<->: T.uncurry++-- |'T.swap' the components of a pair.+swap :: (a, b) <-> (b, a)+swap = [biCase|(a, b) <-> (b, a)|]++flatten2_1 :: ((a, b), c) <-> (a, b, c)+flatten2_1 = [biCase|((a, b), c) <-> (a, b, c)|]++flatten1_2 :: (a, (b, c)) <-> (a, b, c)+flatten1_2 = [biCase|(a, (b, c)) <-> (a, b, c)|]++flatten3_1 :: ((a, b, c), d) <-> (a, b, c, d)+flatten3_1 = [biCase|((a, b, c), d) <-> (a, b, c, d)|]++flatten1_3 :: (a, (b, c, d)) <-> (a, b, c, d)+flatten1_3 = [biCase|(a, (b, c, d)) <-> (a, b, c, d)|]++flatten2_2 :: ((a, b), (c, d)) <-> (a, b, c, d)+flatten2_2 = [biCase|((a, b), (c, d)) <-> (a, b, c, d)|]++flatten1_4 :: (a, (b, c, d, e)) <-> (a, b, c, d, e)+flatten1_4 = [biCase|(a, (b, c, d, e)) <-> (a, b, c, d, e)|]++flatten4_1 :: ((a, b, c, d), e) <-> (a, b, c, d, e)+flatten4_1 = [biCase|((a, b, c, d), e) <-> (a, b, c, d, e)|]
+ Data/Invertible/TypeCompose.hs view
@@ -0,0 +1,17 @@+-- |+-- Convert bijections to and from TypeCompose 'Bijection'.+module Data.Invertible.TypeCompose+  ( toBi+  , fromBi+  ) where++import Data.Invertible.Bijection+import qualified Data.Bijection as T++-- |Convert an isomorphism to semigroupoid form.+toBi :: Bijection a b c -> T.Bijection a b c+toBi (f :<->: g) = T.Bi f g++-- |Convert semigroupoid form to an isomorphism.+fromBi :: T.Bijection a b c -> Bijection a b c+fromBi (T.Bi f g) = f :<->: g
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ invertible.cabal view
@@ -0,0 +1,97 @@+name:                invertible+version:             0.1+synopsis:            bidirectional arrows, bijective functions, and invariant functors+description:+  Representations and operations for bidirectional arrows (total isomorphisms: an+  arrow paired with its inverse).  Classes for invariant functors and monoidal+  functors.  Includes a number of useful bijections and operations, as well as+  interoperability with related packages.+  .+  Most users will want to import one or more of "Data.Invertible" qualified, "Control.Invertible.Monoidal" unqualified, and any additional compatibility modules.+license:             BSD3+author:              Dylan Simon+maintainer:          dylan@dylex.net+copyright:           2016+category:            Data, Control, Composition+build-type:          Simple+cabal-version:       >=1.10+tested-with:         GHC == 7.10.3++source-repository head+  type: git+  location: https://github.com/dylex/invertible++flag arrows+  description: Support the arrows package+flag HList+  description: Support the HList package+flag invariant+  description: Support the invariant package+flag lens+  description: Support the lens package+flag partial-isomorphisms+  description: Support the partial-isomorphisms package+flag Piso+  description: Support the Piso package+flag semigroupoids+  description: Support the semigroupoids package+flag TypeCompose+  description: Support the TypeCompose package++library+  other-modules:+    Data.Invertible.Internal+  exposed-modules:+    Data.Invertible.Bijection+    Data.Invertible.TH+    Data.Invertible.Bits+    Data.Invertible.Bool+    Data.Invertible.Coerce+    Data.Invertible.Complex+    Data.Invertible.Either+    Data.Invertible.Function+    Data.Invertible.Functor+    Data.Invertible.List+    Data.Invertible.Maybe+    Data.Invertible.Monoid+    Data.Invertible.Ord+    Data.Invertible.Tuple+    Data.Invertible.Prelude+    Data.Invertible+    Control.Invertible.BiArrow+    Control.Invertible.MonadArrow+    Control.Invertible.Functor+    Control.Invertible.Monoidal++  build-depends:+    base >= 4.8 && <5,+    haskell-src-meta == 0.6.*,+    template-haskell == 2.*+  default-language:    Haskell2010+  default-extensions: TypeOperators, QuasiQuotes+  ghc-options: -Wall++  if flag(arrows)+    build-depends: arrows+  if flag(HList)+    exposed-modules: Data.Invertible.HList+    exposed-modules: Control.Invertible.Monoidal.HList+    build-depends: HList == 0.4.*+  if flag(invariant)+    exposed-modules: Data.Invertible.Invariant+    build-depends: invariant+  if flag(lens)+    exposed-modules: Data.Invertible.Lens+    build-depends: lens == 4.*+  if flag(partial-isomorphisms)+    exposed-modules: Data.Invertible.PartialIsomorphism+    build-depends: partial-isomorphisms+  if flag(Piso)+    exposed-modules: Data.Invertible.Piso+    build-depends: Piso+  if flag(semigroupoids)+    exposed-modules: Data.Invertible.Semigroupoid+    build-depends: semigroupoids >= 4+  if flag(TypeCompose)+    exposed-modules: Data.Invertible.TypeCompose+    build-depends: TypeCompose >= 0.3