module Control.Isomorphic where
import Control.Applicative
import Control.Arrow
import qualified Control.Monad.ST.Lazy as SL
import qualified Control.Monad.ST.Strict as SS
import qualified Control.Newtype as N
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Fixed
import Data.Functor.Compose
import Data.Functor.Identity
import qualified Data.List.NonEmpty as NE
import Data.Monoid
import Data.Profunctor (Profunctor (..))
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TSE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import GHC.Generics (C1, D1, Generic, K1 (..), M1 (..),
S1)
class Isomorphic b a => Isomorphic a b where
to' :: a -> b
instance Isomorphic (D1 d (C1 c (S1 s (K1 i a))) a) a where
to' (M1 (M1 (M1 (K1 x)))) = x
instance Isomorphic a (D1 d (C1 c (S1 s (K1 i a))) a) where
to' x = (M1 (M1 (M1 (K1 x))))
via :: forall b a c. (Isomorphic b c, Isomorphic a b) => a -> c
via = from @b . to
to :: forall b a. Isomorphic a b => a -> b
to = to'
from :: forall a b. Isomorphic a b => a -> b
from = to'
instance Isomorphic a a where to' = id
instance Isomorphic (a,b) (b,a) where to' (a,b) = (b,a)
instance Isomorphic (a,(b,c)) ((a,b),c) where to' (a,(b,c)) = ((a,b),c)
instance Isomorphic ((a,b),c) (a,(b,c)) where to' ((a,b),c) = (a,(b,c))
instance Isomorphic (a,b,c) (a,(b,c)) where to' (a,b,c) = (a,(b,c))
instance Isomorphic (a,(b,c)) (a,b,c) where to' (a,(b,c)) = (a,b,c)
instance Isomorphic (a,b,c) ((a,b),c) where to' (a,b,c) = ((a,b),c)
instance Isomorphic ((a,b),c) (a,b,c) where to' ((a,b),c) = (a,b,c)
instance Isomorphic BS.ByteString String where
to' = BSC.unpack
instance Isomorphic String BS.ByteString where
to' = BSC.pack
instance Isomorphic BL.ByteString String where
to' = BLC.unpack
instance Isomorphic String BL.ByteString where
to' = BLC.pack
instance Isomorphic TS.Text String where
to' = TS.unpack
instance Isomorphic String TS.Text where
to' = TS.pack
instance Isomorphic TL.Text String where
to' = TL.unpack
instance Isomorphic String TL.Text where
to' = TL.pack
instance Isomorphic TS.Text BS.ByteString where
to' = TSE.encodeUtf8
instance Isomorphic BS.ByteString TS.Text where
to' = TSE.decodeUtf8
instance Isomorphic TS.Text BL.ByteString where
to' = BL.fromStrict . to
instance Isomorphic BL.ByteString TS.Text where
to' = to' . BL.toStrict
instance Isomorphic TS.Text TL.Text where
to' = TL.fromStrict
instance Isomorphic TL.Text TS.Text where
to' = TL.toStrict
instance Isomorphic TL.Text BS.ByteString where
to' = BL.toStrict . to
instance Isomorphic BS.ByteString TL.Text where
to' = to' . BL.fromStrict
instance Isomorphic TL.Text BL.ByteString where
to' = TLE.encodeUtf8
instance Isomorphic BL.ByteString TL.Text where
to' = TLE.decodeUtf8
instance Isomorphic BS.ByteString BL.ByteString where
to' = BL.fromStrict
instance Isomorphic BL.ByteString BS.ByteString where
to' = BL.toStrict
instance Isomorphic (Maybe a) (Either () a) where
to' = \case Just a -> Right a; _ -> Left ()
instance Isomorphic (Either () a) (Maybe a) where
to' = \case Right a -> Just a; _ -> Nothing
instance Isomorphic (Maybe a) (Either a ()) where
to' = \case Just a -> Left a; _ -> Right ()
instance Isomorphic (Either a ()) (Maybe a) where
to' = \case Left a -> Just a; _ -> Nothing
instance Isomorphic (a -> b -> c) ((a,b) -> c) where to' = uncurry
instance Isomorphic ((a,b) -> c) (a -> b -> c) where to' = curry
instance Isomorphic (a -> b -> c) (b -> a -> c) where to' = flip
instance Isomorphic (Either a b) (Either b a) where
to' = \case Right x -> Left x; Left x -> Right x
instance Isomorphic (NE.NonEmpty a) (a, [a]) where to' (x NE.:| xs) = (x,xs)
instance Isomorphic (a, [a]) (NE.NonEmpty a) where to' (x,xs) = x NE.:| xs
newtype IsRight = IsRight { unIsRight :: Either () () } deriving (Show, Generic)
newtype IsLeft = IsLeft { unIsLeft :: Either () () } deriving (Show, Generic)
instance Isomorphic IsRight (Either () ()) where to' = unIsRight
instance Isomorphic (Either () ()) IsRight where to' = IsRight
instance Isomorphic IsLeft (Either () ()) where to' = unIsLeft
instance Isomorphic (Either () ()) IsLeft where to' = IsLeft
instance Isomorphic Bool IsRight where
to' True = IsRight (Right ())
to' _ = IsRight (Left ())
instance Isomorphic IsRight Bool where
to' (IsRight (Right ())) = True
to' _ = False
instance Isomorphic Bool IsLeft where
to' True = IsLeft (Left ())
to' _ = IsLeft (Right ())
instance Isomorphic IsLeft Bool where
to' (IsLeft (Left ())) = True
to' _ = False
instance Enum a => Isomorphic a Int where to' = fromEnum
instance Enum a => Isomorphic Int a where to' = toEnum
instance Isomorphic (SL.ST s a) (SS.ST s a) where to' = SL.lazyToStrictST
instance Isomorphic (SS.ST s a) (SL.ST s a) where to' = SL.strictToLazyST
newtype IsJust = IsJust { unIsJust :: Maybe () } deriving Show
newtype IsNothing = IsNothing { unIsNothing :: Maybe () } deriving Show
instance Isomorphic IsJust (Maybe ()) where to' = unIsJust
instance Isomorphic (Maybe ()) IsJust where to' = IsJust
instance Isomorphic IsNothing (Maybe ()) where to' = unIsNothing
instance Isomorphic (Maybe ()) IsNothing where to' = IsNothing
instance Isomorphic Bool IsJust where
to' True = IsJust (Just ())
to' _ = IsJust Nothing
instance Isomorphic IsJust Bool where
to' (IsJust (Just ())) = True
to' _ = False
instance Isomorphic Bool IsNothing where
to' True = IsNothing Nothing
to' _ = IsNothing (Just ())
instance Isomorphic IsNothing Bool where
to' (IsNothing Nothing) = True
to' _ = False
instance Isomorphic (WrappedMonad m a) (m a) where to' = N.unpack
instance Isomorphic (m a) (WrappedMonad m a) where to' = N.pack
instance Isomorphic (WrappedArrow a b c) (a b c) where to' = N.unpack
instance Isomorphic (a b c) (WrappedArrow a b c) where to' = N.pack
instance Isomorphic (ZipList a) [a] where to' = N.unpack
instance Isomorphic [a] (ZipList a) where to' = N.pack
instance Isomorphic (Kleisli m a b) (a -> m b) where to' = N.unpack
instance Isomorphic (a -> m b) (Kleisli m a b) where to' = N.pack
instance Isomorphic (ArrowMonad a b) (a () b) where to' = N.unpack
instance Isomorphic (a () b) (ArrowMonad a b) where to' = N.pack
instance Isomorphic (Fixed a) Integer where to' = N.unpack
instance Isomorphic Integer (Fixed a) where to' = N.pack
instance Isomorphic (Compose f g a) (f (g a)) where to' = N.unpack
instance Isomorphic (f (g a)) (Compose f g a) where to' = N.pack
instance Isomorphic (Const a x) a where to' = N.unpack
instance Isomorphic a (Const a x) where to' = N.pack
instance Isomorphic (Identity a) a where to' = N.unpack
instance Isomorphic a (Identity a) where to' = N.pack
instance Isomorphic (Dual a) a where to' = N.unpack
instance Isomorphic a (Dual a) where to' = N.pack
instance Isomorphic (Endo a) (a -> a) where to' = N.unpack
instance Isomorphic (a -> a) (Endo a) where to' = N.pack
instance Isomorphic All Bool where to' = N.unpack
instance Isomorphic Bool All where to' = N.pack
instance Isomorphic Any Bool where to' = N.unpack
instance Isomorphic Bool Any where to' = N.pack
instance Isomorphic (Sum a) a where to' = N.unpack
instance Isomorphic a (Sum a) where to' = N.pack
instance Isomorphic (Product a) a where to' = N.unpack
instance Isomorphic a (Product a) where to' = N.pack
instance Isomorphic (First a) (Maybe a) where to' = N.unpack
instance Isomorphic (Maybe a) (First a) where to' = N.pack
instance Isomorphic (Last a) (Maybe a) where to' = N.unpack
instance Isomorphic (Maybe a) (Last a) where to' = N.pack
as :: (Isomorphic b d, Isomorphic c a) => (a -> b) -> c -> d
as f = to . f . to
as2 :: (Isomorphic c f, Isomorphic d a, Isomorphic e b) => (a -> b -> c) -> d -> e -> f
as2 f x y = to $ f (to x) (to y)
as3 :: (Isomorphic d h, Isomorphic e a, Isomorphic f b, Isomorphic g c) => (a -> b -> c -> d) -> e -> f -> g -> h
as3 f x y z = to $ f (to x) (to y) (to z)
as4 :: (Isomorphic e j, Isomorphic f a, Isomorphic g b, Isomorphic h c, Isomorphic i d) => (a -> b -> c -> d -> e) -> f -> g -> h -> i -> j
as4 f w x y z = to $ f (to w) (to x) (to y) (to z)
as5 :: (Isomorphic f l, Isomorphic g a, Isomorphic h b, Isomorphic i c, Isomorphic j d, Isomorphic k e) => (a -> b -> c -> d -> e -> f) -> g -> h -> i -> j -> k -> l
as5 f v w x y z = to $ f (to v) (to w) (to x) (to y) (to z)
isoBi :: (Profunctor p, Isomorphic s a, Isomorphic b t, Functor f) => p a (f b) -> p s (f t)
isoBi = dimap to (fmap to)