Isomorphic.hs

{-# LANGUAGE AllowAmbiguousTypes     #-}
{-# LANGUAGE DeriveGeneric           #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE LambdaCase              #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeFamilyDependencies  #-}
{-# LANGUAGE UndecidableSuperClasses #-}

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
  {-|
   This type class provides a single method `to'`, which is a __bijective__ function from `a` to `b`.
   We leverage `UndecidableSuperClasses` to demand that every instance of `Isomorphic` have an inverse.
   The sister instance (which may be the same instance) must have the follwing property when used with
   the `to'`

   @
     to' . to' = id
   @

   Note, this class documents type isomorphisms specifically, where two types are isomorphic to one another.
   It does not document endoisomorphisms.
  -}
  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))))

-- | Composition of two bijections
via :: forall b a c. (Isomorphic b c, Isomorphic a b) => a -> c
via = from @b . to
{-# INLINE via #-}

{-| This is the perfer version of the `to'` function.
    The order of arguments in @forall@ has been set up so that the codomain is first.
    This is important to work with `TypeApplications`.

    @
      to @Text "hi there"
    @

    For call sites where we need to annotate.
-}
to :: forall b a. Isomorphic a b => a -> b
to = to'
{-# INLINE to #-}

{-| This is the same as `to` but has the @forall@ arguments with @a@ first.
-}
from :: forall a b. Isomorphic a b => a -> b
from = to'
{-# INLINE from #-}

instance {-# OVERLAPPABLE #-} Isomorphic a a where to' = id
                                                   {-# INLINE to' #-}

instance Isomorphic (a,b) (b,a) where to' (a,b) = (b,a)
                                      {-# INLINABLE to' #-}


instance Isomorphic (a,(b,c)) ((a,b),c) where to' (a,(b,c)) = ((a,b),c)
                                              {-# INLINABLE to' #-}
instance Isomorphic ((a,b),c) (a,(b,c)) where to' ((a,b),c) = (a,(b,c))
                                              {-# INLINABLE to' #-}

instance Isomorphic (a,b,c) (a,(b,c))   where to' (a,b,c) = (a,(b,c))
                                              {-# INLINABLE to' #-}
instance Isomorphic (a,(b,c)) (a,b,c)   where to' (a,(b,c)) = (a,b,c)
                                              {-# INLINABLE to' #-}

instance Isomorphic (a,b,c) ((a,b),c)   where to' (a,b,c) = ((a,b),c)
                                              {-# INLINABLE to' #-}
instance Isomorphic ((a,b),c) (a,b,c)   where to' ((a,b),c) = (a,b,c)
                                              {-# INLINABLE to' #-}

-- String -> BS BL TS TL

instance Isomorphic BS.ByteString String where
  to' = BSC.unpack
  {-# INLINE to' #-}
instance Isomorphic String BS.ByteString where
  to' = BSC.pack
  {-# INLINE to' #-}

instance Isomorphic BL.ByteString String where
  to' = BLC.unpack
  {-# INLINE to' #-}
instance Isomorphic String BL.ByteString where
  to' = BLC.pack
  {-# INLINE to' #-}

instance Isomorphic TS.Text String where
  to' = TS.unpack
  {-# INLINE to' #-}
instance Isomorphic String TS.Text where
  to' = TS.pack
  {-# INLINE to' #-}

instance Isomorphic TL.Text String where
  to' = TL.unpack
  {-# INLINE to' #-}
instance Isomorphic String TL.Text where
  to' = TL.pack
  {-# INLINE to' #-}

-- TS -> BS BL TL

instance Isomorphic TS.Text BS.ByteString where
  to' = TSE.encodeUtf8
  {-# INLINE to' #-}
instance Isomorphic BS.ByteString TS.Text where
  to' = TSE.decodeUtf8
  {-# INLINE to' #-}

instance Isomorphic TS.Text BL.ByteString where
  to' = BL.fromStrict . to
  {-# INLINE to' #-}
instance Isomorphic BL.ByteString TS.Text where
  to' = to' . BL.toStrict
  {-# INLINE to' #-}

instance Isomorphic TS.Text TL.Text where
  to' = TL.fromStrict
  {-# INLINE to' #-}
instance Isomorphic TL.Text TS.Text where
  to' = TL.toStrict
  {-# INLINE to' #-}

-- TL -> BS BL


instance Isomorphic TL.Text BS.ByteString where
  to' = BL.toStrict . to
  {-# INLINE to' #-}
instance Isomorphic BS.ByteString TL.Text where
  to' = to' . BL.fromStrict
  {-# INLINE to' #-}

instance Isomorphic TL.Text BL.ByteString where
  to' = TLE.encodeUtf8
  {-# INLINE to' #-}
instance Isomorphic BL.ByteString TL.Text where
  to' = TLE.decodeUtf8
  {-# INLINE to' #-}

-- BS -> BL

instance Isomorphic BS.ByteString BL.ByteString where
  to' = BL.fromStrict
  {-# INLINE to' #-}
instance Isomorphic BL.ByteString BS.ByteString where
  to' = BL.toStrict
  {-# INLINE to' #-}

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
                                                     {-# INLINE to' #-}
instance Isomorphic ((a,b) -> c) (a -> b -> c) where to' = curry
                                                     {-# INLINE to' #-}

instance Isomorphic (a -> b -> c) (b -> a -> c) where to' = flip
                                                      {-# INLINE to' #-}

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

-- | A wrapper for @Either () ()@ that decides the isomorphism to `Bool` is `Right` biased
newtype IsRight = IsRight { unIsRight :: Either () () } deriving (Show, Generic)
-- | A wrapper for @Either () ()@ that decides the isomorphism to `Bool` is `Left` biased
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
                                          {-# INLINE to' #-}
instance Enum a => Isomorphic Int a where to' = toEnum
                                          {-# INLINE to' #-}

instance Isomorphic (SL.ST s a) (SS.ST s a) where to' = SL.lazyToStrictST
                                                  {-# INLINE to' #-}
instance Isomorphic (SS.ST s a)  (SL.ST s a) where to' = SL.strictToLazyST
                                                   {-# INLINE to' #-}

-- | A wrapper for @Maybe ()@ that decides the isomorphism to `Bool` is `Just` biased
newtype IsJust = IsJust { unIsJust :: Maybe () } deriving Show
-- | A wrapper for @Maybe ()@ that decides the isomorphism to `Bool` is `Nothing` biased
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

-- | lift a function to any types to which it is isomorphic
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)

-- | A free lens @Iso s t a b@ from the `Isomorphic` instances
isoBi :: (Profunctor p, Isomorphic s a, Isomorphic b t, Functor f) => p a (f b) -> p s (f t)
isoBi = dimap to (fmap to)