Converted to experimental TypeFamily-based isos and projections

lens.cabal

@@ -143,11 +143,16 @@ flag test-hunit
   default: True
   manual: True
 
+flag test-properties
+  default: True
+  manual: True
+
 -- Disallow unsafeCoerce
 flag safe
   default: False
   manual: True
 
+
 library
   build-depends:
     base                 >= 4.4      && < 5,
@@ -277,6 +282,8 @@ test-suite properties
     transformers
   ghc-options: -w -threaded
   hs-source-dirs: tests
+  if !flag(test-properties)
+    buildable: False
 
 test-suite hunit
   type: exitcode-stdio-1.0

src/Control/Exception/Lens.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 -----------------------------------------------------------------------------

src/Control/Lens/Classes.hs

@@ -33,6 +33,10 @@ module Control.Lens.Classes
   , Projective(..)
   -- * Indexable
   , Indexable(..)
+  -- * Families
+  , CoalgebraicA
+  , CoalgebraicB
+  , CoalgebraicF
   ) where
 
 import Control.Applicative
@@ -139,11 +143,23 @@ instance (Settable f, Settable g) => Settable (Compose f g) where
 -- Isomorphisms
 -----------------------------------------------------------------------------
 
+type family CoalgebraicA (x :: *) :: *
+type family CoalgebraicB (x :: *) :: *
+type family CoalgebraicF (x :: *) :: * -> *
+
+type instance CoalgebraicA (a -> f_b) = a
+type instance CoalgebraicB (a -> f b) = b
+type instance CoalgebraicF (a -> f b) = f
+
 -- | Used to provide overloading of isomorphism application
 --
 -- An instance of 'Isomorphic' is a 'Category' with a canonical mapping to it from the
 -- category of isomorphisms over Haskell types.
-class Isomorphic r s t a b | r -> s t a b, s b -> t a, t a -> s b where
+class Isomorphic r where
+  type S (r :: *) :: *
+  type T (r :: *) :: *
+  type A (r :: *) :: *
+  type B (r :: *) :: *
   -- | Build a simple isomorphism from a pair of inverse functions
   --
   -- @
@@ -152,9 +168,13 @@ class Isomorphic r s t a b | r -> s t a b, s b -> t a, t a -> s b where
   -- 'set' ('iso' f g) h ≡ g '.' h '.' f
   -- 'set' ('from' ('iso' f g)) h ≡ f '.' h '.' g
   -- @
-  iso :: (s -> a) -> (b -> t) -> r
+  iso :: (S r -> A r) -> (B r -> T r) -> r
 
-instance (Functor f, x ~ (a -> f b), y ~ (s -> f t)) => Isomorphic (x -> y) s t a b where
+instance (Functor f, x ~ (a -> f b), y ~ (s -> f t)) => Isomorphic (x -> y) where
+  type S (x -> y) = CoalgebraicA y
+  type T (x -> y) = CoalgebraicB y
+  type A (x -> y) = CoalgebraicA x
+  type B (x -> y) = CoalgebraicB x
   iso sa bt afb s = bt <$> afb (sa s)
 
 -----------------------------------------------------------------------------
@@ -165,13 +185,13 @@ instance (Functor f, x ~ (a -> f b), y ~ (s -> f t)) => Isomorphic (x -> y) s t
 --
 -- An instance of 'Projective' is a 'Category' with a canonical mapping to it from the category
 -- of embedding-projection pairs over Haskell types.
-class Isomorphic r s t a b => Projective r s t a b | r -> s t a b, s b -> t a, t a -> s b where
+class Isomorphic r => Projective r where
   -- | Build a 'Control.Lens.Projection.Projection'.
   --
   -- @'Either' t a@ is used instead of @'Maybe' a@ to permit the types of @s@ and @t@ to differ.
-  projected :: (b -> t) -> (s -> Either t a) -> r
+  projected :: (B r -> T r) -> (S r -> Either (T r) (A r)) -> r
 
-instance (Applicative f, x ~ (a -> f b), y ~ (s -> f t)) => Projective (x -> y) s t a b where
+instance (Applicative f, x ~ (a -> f b), y ~ (s -> f t)) => Projective (x -> y) where
   projected bt seta afb = either pure (fmap bt . afb) . seta
   {-# INLINE projected #-}
 

src/Control/Lens/Internal.hs

@@ -493,12 +493,16 @@ instance Category Projected where
         Right a -> Right a
 -}
 
-instance Projective (Projected s t a b) s t a b where
-  projected = Projected
-
-instance Isomorphic (Projected s t a b) s t a b where
+instance Isomorphic (Projected s t a b) where
+  type S (Projected s t a b) = s
+  type T (Projected s t a b) = t
+  type A (Projected s t a b) = a
+  type B (Projected s t a b) = b
   iso sa bt = Projected bt (Right . sa)
 
+instance Projective (Projected s t a b) where
+  projected = Projected
+
 ------------------------------------------------------------------------------
 -- Isomorphism Internals
 ------------------------------------------------------------------------------
@@ -512,7 +516,11 @@ instance Category Isomorphism where
   Isomorphism xs ty . Isomorphism sa bt = Isomorphism (sa.xs) (ty.bt)
 -}
 
-instance Isomorphic (Isomorphism s t a b) s t a b where
+instance Isomorphic (Isomorphism s t a b) where
+  type S (Isomorphism s t a b) = s
+  type T (Isomorphism s t a b) = t
+  type A (Isomorphism s t a b) = a
+  type B (Isomorphism s t a b) = b
   iso = Isomorphism
 
 ------------------------------------------------------------------------------

src/Control/Lens/Iso.hs

@@ -26,7 +26,7 @@ module Control.Lens.Iso
   -- * Isomorphism Lenses
     Iso
   -- * Isomorphism Construction
-  , Isomorphic(..)
+  , Isomorphic(iso)
   , Isomorphism(..)
   -- * Consuming Isomorphisms
   , from
@@ -109,7 +109,7 @@ cloneIso (Isomorphism sa bt) = iso sa bt
 -- import Prelude hiding (('Prelude..'),'Prelude.id')
 -- @
 --
-type Iso s t a b = forall r. Isomorphic r s t a b => r
+type Iso s t a b = forall r. (Isomorphic r, S r ~ s, T r ~ t, A r ~ a, B r ~ b) => r
 
 -- |
 -- @type 'SimpleIso' = 'Control.Lens.Type.Simple' 'Iso'@

src/Control/Lens/Projection.hs

@@ -55,7 +55,7 @@ import Prelude hiding (id,(.))
 -- $setup
 -- >>> import Control.Lens
 -- >>> import Numeric.Natural
--- >>> :set -XFlexibleContexts
+-- >>> :set -XFlexibleContexts -XTypeFamilies
 -- >>> let nat :: Simple Projection Integer Natural; nat = projected toInteger $ \i -> if i <= 0 then Left i else Right (fromInteger i)
 -- >>> let isLeft  (Left  _) = True; isLeft  _ = False
 -- >>> let isRight (Right _) = True; isRight _ = False
@@ -126,7 +126,7 @@ import Prelude hiding (id,(.))
 --
 -- Another interesting way to think of a 'Projection' is as the categorical dual of a 'Lens'
 -- a /co/-'Lens', so to speak. This is what permits the construction of 'outside'.
-type Projection s t a b = forall r. Projective r s t a b => r
+type Projection s t a b = forall r. (Projective r, S r ~ s, T r ~ t, A r ~ a, B r ~ b) => r
 
 -- | A @'Simple' 'Projection'@.
 type SimpleProjection s a = Projection s s a a

src/Control/Lens/Simple.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |

src/Control/Lens/Wrapped.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}

src/Data/ByteString/Lazy/Lens.hs

@@ -1,12 +1,13 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.ByteString.Lazy.Lens
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 -- Lenses for lazy bytestrings
 ----------------------------------------------------------------------------

src/Data/ByteString/Lens.hs

@@ -1,12 +1,13 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.ByteString.Lens
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.ByteString.Lens

src/Data/ByteString/Strict/Lens.hs

@@ -1,12 +1,13 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.ByteString.Strict.Lens
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.ByteString.Strict.Lens

src/Data/Complex/Lens.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 #ifndef MIN_VERSION_base
 #define MIN_VERSION_base(x,y,z) 1
@@ -10,7 +11,7 @@
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 -- Stability   :  experimental
--- Portability :  Rank2Types
+-- Portability :  non-portable
 --
 -- Lenses and traversals for complex numbers
 --

src/Data/Dynamic/Lens.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |

src/Data/Sequence/Lens.hs

@@ -1,13 +1,14 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Sequence.Lens
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.Sequence.Lens

src/Data/Text/Lazy/Lens.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
 {-# LANGUAGE Trustworthy #-}
 #endif
@@ -10,8 +11,8 @@
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.Text.Lazy.Lens

src/Data/Text/Lens.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
 {-# LANGUAGE Trustworthy #-}
@@ -9,8 +10,8 @@
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.Text.Lens

src/Data/Text/Strict/Lens.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
 {-# LANGUAGE Trustworthy #-}
@@ -9,8 +10,8 @@
 -- Copyright   :  (C) 2012 Edward Kmett
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
+-- Stability   :  experimental
+-- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
 module Data.Text.Strict.Lens

src/GHC/Generics/Lens.hs

@@ -1,7 +1,8 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LiberalTypeSynonyms #-}
-{-# LANGUAGE Rank2Types #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Generics.Lens

tests/hunit.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Main where
 

tests/properties.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ExtendedDefaultRules #-}

tests/templates.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}