control-iso (empty) → 0.1.0.0
raw patch · 5 files changed
+382/−0 lines, 5 filesdep +basedep +bytestringdep +newtype-genericssetup-changed
Dependencies added: base, bytestring, newtype-generics, profunctors, text
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- control-iso.cabal +34/−0
- src/Control/Isomorphic.hs +311/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for control-iso++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Isaac Shapira++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Shapira nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ control-iso.cabal view
@@ -0,0 +1,34 @@+-- Initial control-iso.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: control-iso+version: 0.1.0.0+synopsis: A typeclass for type isomorphisms+description: This is a type class for type isomorphisms, it provides string conversions as well as for newtypes and common types+license: BSD3+license-file: LICENSE+author: Isaac Shapira+maintainer: fresheyeball@gmail.com+-- copyright:+category: Control+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://gitlab.com/fresheyeball/control-iso.git++library+ exposed-modules: Control.Isomorphic+ -- other-modules:+ -- other-extensions:+ ghc-options: -Wall+ build-depends: base >= 4.9 && <4.10.2+ , bytestring >= 0.10.8 && < 0.11+ , newtype-generics >= 0.5.1 && < 0.6+ , profunctors >= 5.2.1 && < 5.3+ , text >= 1.2.2 && < 1.3++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Control/Isomorphic.hs view
@@ -0,0 +1,311 @@+{-# 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)