Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added 'Control.Lens.Equality'

  • Loading branch information...
commit 3ce55f473bb7d7ad0ec984b31956a9447991cc63 1 parent c8a66a1
@ekmett authored
View
1  lens.cabal
@@ -196,6 +196,7 @@ library
Control.Lens.At
Control.Lens.Combinators
Control.Lens.Each
+ Control.Lens.Equality
Control.Lens.Fold
Control.Lens.Getter
Control.Lens.Indexed
View
13 src/Control/Exception/Lens.hs
@@ -1,7 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
@@ -44,6 +46,7 @@ module Control.Exception.Lens
, AsErrorCall(..)
) where
+import Control.Applicative
import Control.Exception
import Control.Lens
import Data.Monoid
@@ -181,14 +184,16 @@ throwingTo tid l = reviews l (throwTo tid)
----------------------------------------------------------------------------
-- Exceptions that occur in the IO monad. An IOException records a more specific error type, a descriptive string and maybe the handle that was used when the error was flagged.
-class AsIOException t where
- ioException :: Prism' t IOException
+class AsIOException p f t where
+ ioException :: Overloading' p p f t IOException
-instance AsIOException IOException where
+-- | @'ioException' :: 'Equality'' 'IOException' 'IOException'@
+instance AsIOException k f IOException where
ioException = id
{-# INLINE ioException #-}
-instance AsIOException SomeException where
+-- | @'ioException' :: 'Prism'' 'SomeException' 'IOException'@
+instance (Prismatic k, Applicative f) => AsIOException k f SomeException where
ioException = exception
{-# INLINE ioException #-}
View
2  src/Control/Lens.hs
@@ -44,6 +44,7 @@ module Control.Lens
, module Control.Lens.At
, module Control.Lens.Combinators
, module Control.Lens.Each
+ , module Control.Lens.Equality
, module Control.Lens.Fold
, module Control.Lens.Getter
, module Control.Lens.Indexed
@@ -71,6 +72,7 @@ import Control.Lens.Action
import Control.Lens.At
import Control.Lens.Combinators
import Control.Lens.Each
+import Control.Lens.Equality
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Indexed
View
62 src/Control/Lens/Equality.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Lens.Equality
+-- Copyright : (C) 2012 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : provisional
+-- Portability : Rank2Types
+--
+----------------------------------------------------------------------------
+module Control.Lens.Equality
+ (
+ -- * Type Equality
+ Equality, Equality'
+ , AnEquality, AnEquality'
+ , runEq
+ , substEq
+ , mapEq
+ , fromEq
+ -- * Implementation Details
+ , Identical(..)
+ ) where
+
+import Control.Lens.Internal
+import Control.Lens.Type
+
+-- $setup
+-- >>> import Control.Lens
+
+-----------------------------------------------------------------------------
+-- Equality
+-----------------------------------------------------------------------------
+
+-- | When you see this as an argument to a function, it expects an 'Equality'.
+type AnEquality s t a b = Identical a (Mutator b) a (Mutator b) -> Identical a (Mutator b) s (Mutator t)
+
+-- | A 'Simple' 'AnEquality'
+type AnEquality' s a = AnEquality s s a a
+
+-- | Extract a witness of type equality
+runEq :: forall s t a b. Equality s t a b -> Identical s t a b
+runEq l = case l (Identical :: Identical a (Mutator b) a (Mutator b)) of
+ Identical -> Identical
+
+-- | Substituting types with equality
+substEq :: Equality s t a b -> ((s ~ a, t ~ b) => r) -> r
+substEq l = case runEq l of
+ Identical -> \r -> r
+
+-- | We can use equality to do substitution into anything
+mapEq :: Equality s t a b -> f s -> f a
+mapEq l r = substEq l r
+
+-- | Equality is symmetric
+fromEq :: Equality s t a b -> Equality b a t s
+fromEq l = substEq l id
View
8 src/Control/Lens/Internal.hs
@@ -68,6 +68,7 @@ module Control.Lens.Internal
, Review(..)
, Exchange(..)
, Market(..)
+ , Identical(..)
, Indexed(..)
) where
@@ -813,6 +814,13 @@ instance Prismatic (Market a b) where
{-# INLINE prismatic #-}
------------------------------------------------------------------------------
+-- Equality Internals
+------------------------------------------------------------------------------
+
+data Identical a b s t where
+ Identical :: Identical a b a b
+
+------------------------------------------------------------------------------
-- Indexed Internals
------------------------------------------------------------------------------
View
12 src/Control/Lens/Type.hs
@@ -23,6 +23,7 @@ module Control.Lens.Type
, Iso, Iso'
, Prism , Prism'
, Setter, Setter'
+ , Equality, Equality'
, Getter
, Fold
, Action
@@ -322,6 +323,16 @@ type Prism s t a b = forall p f. (Prismatic p, Applicative f) => p a (f b) -> p
type Prism' s a = Prism s s a a
-------------------------------------------------------------------------------
+-- Equality
+-------------------------------------------------------------------------------
+
+-- | A witness that @(a ~ s, b ~ t)@
+type Equality s t a b = forall p f. p a (f b) -> p s (f t)
+
+-- | A 'Simple' 'Equality'
+type Equality' s a = Equality s s a a
+
+-------------------------------------------------------------------------------
-- Getters
-------------------------------------------------------------------------------
@@ -362,6 +373,7 @@ type Fold s a = forall f. (Gettable f, Applicative f) => (a -> f a) -> s -> f s
type IndexedFold i s a = forall p f.
(Indexable i p, Applicative f, Gettable f) => p a (f a) -> s -> f s
+
-------------------------------------------------------------------------------
-- Actions
-------------------------------------------------------------------------------
Please sign in to comment.
Something went wrong with that request. Please try again.