Permalink
Fetching contributors…
Cannot retrieve contributors at this time
377 lines (344 sloc) 10.2 KB
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
-------------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Prism
-- Copyright : (C) 2012-16 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
-------------------------------------------------------------------------------
module Control.Lens.Prism
(
-- * Prisms
Prism, Prism'
, APrism, APrism'
-- * Constructing Prisms
, prism
, prism'
-- * Consuming Prisms
, withPrism
, clonePrism
, outside
, aside
, without
, below
, isn't
, matching
-- * Common Prisms
, _Left
, _Right
, _Just
, _Nothing
, _Void
, _Show
, only
, nearly
-- * Prismatic profunctors
, Choice(..)
) where
import Control.Applicative
import Control.Lens.Internal.Prism
import Control.Lens.Lens
import Control.Lens.Review
import Control.Lens.Type
import Control.Monad
import Data.Functor.Identity
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Traversable
import Data.Void
#if MIN_VERSION_base(4,7,0)
import Data.Coerce
#elif defined(SAFE)
import Data.Profunctor.Unsafe
#else
import Unsafe.Coerce
#endif
import Prelude
{-# ANN module "HLint: ignore Use camelCase" #-}
-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Numeric.Natural
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let isLeft (Left _) = True; isLeft _ = False
-- >>> let isRight (Right _) = True; isRight _ = False
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g
------------------------------------------------------------------------------
-- Prism Internals
------------------------------------------------------------------------------
-- | If you see this in a signature for a function, the function is expecting a 'Prism'.
type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
-- | @
-- type APrism' = 'Simple' 'APrism'
-- @
type APrism' s a = APrism s s a a
-- | Convert 'APrism' to the pair of functions that characterize it.
withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
#if MIN_VERSION_base(4,7,0)
withPrism k f = case coerce (k (Market Identity Right)) of
Market bt seta -> f bt seta
#elif defined(SAFE)
withPrism k f = case k (Market Identity Right) of
Market bt seta -> f (runIdentity #. bt) (either (Left . runIdentity) Right . seta)
#else
withPrism k f = case unsafeCoerce (k (Market Identity Right)) of
Market bt seta -> f bt seta
#endif
{-# INLINE withPrism #-}
-- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes.
--
-- See 'Control.Lens.Lens.cloneLens' and 'Control.Lens.Traversal.cloneTraversal' for examples of why you might want to do this.
clonePrism :: APrism s t a b -> Prism s t a b
clonePrism k = withPrism k prism
{-# INLINE clonePrism #-}
------------------------------------------------------------------------------
-- Prism Combinators
------------------------------------------------------------------------------
-- | Build a 'Control.Lens.Prism.Prism'.
--
-- @'Either' t a@ is used instead of @'Maybe' a@ to permit the types of @s@ and @t@ to differ.
--
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'
{-# INLINE prism #-}
-- | This is usually used to build a 'Prism'', when you have to use an operation like
-- 'Data.Typeable.cast' which already returns a 'Maybe'.
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))
{-# INLINE prism' #-}
-- | Use a 'Prism' as a kind of first-class pattern.
--
-- @'outside' :: 'Prism' s t a b -> 'Lens' (t -> r) (s -> r) (b -> r) (a -> r)@
-- TODO: can we make this work with merely Strong?
outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r)
outside k = withPrism k $ \bt seta f ft ->
f (lmap bt ft) <&> \fa -> tabulate $ either (sieve ft) (sieve fa) . seta
{-# INLINE outside #-}
-- | Given a pair of prisms, project sums.
--
-- Viewing a 'Prism' as a co-'Lens', this combinator can be seen to be dual to 'Control.Lens.Lens.alongside'.
without :: APrism s t a b
-> APrism u v c d
-> Prism (Either s u) (Either t v) (Either a c) (Either b d)
without k =
withPrism k $ \bt seta k' ->
withPrism k' $ \dv uevc ->
prism (bimap bt dv) $ \su ->
case su of
Left s -> bimap Left Left (seta s)
Right u -> bimap Right Right (uevc u)
{-# INLINE without #-}
-- | Use a 'Prism' to work over part of a structure.
--
aside :: APrism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside k =
withPrism k $ \bt seta ->
prism (fmap bt) $ \(e,s) ->
case seta s of
Left t -> Left (e,t)
Right a -> Right (e,a)
{-# INLINE aside #-}
-- | 'lift' a 'Prism' through a 'Traversable' functor, giving a Prism that matches only if all the elements of the container match the 'Prism'.
--
-- >>> [Left 1, Right "foo", Left 4, Right "woot"]^..below _Right
-- []
--
-- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"]^..below _Right
-- [["hail hydra!","foo","blah","woot"]]
below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
below k =
withPrism k $ \bt seta ->
prism (fmap bt) $ \s ->
case traverse seta s of
Left _ -> Left s
Right t -> Right t
{-# INLINE below #-}
-- | Check to see if this 'Prism' doesn't match.
--
-- >>> isn't _Left (Right 12)
-- True
--
-- >>> isn't _Left (Left 12)
-- False
--
-- >>> isn't _Empty []
-- False
isn't :: APrism s t a b -> s -> Bool
isn't k s =
case matching k s of
Left _ -> True
Right _ -> False
{-# INLINE isn't #-}
-- | Retrieve the value targeted by a 'Prism' or return the
-- original value while allowing the type to change if it does
-- not match.
--
-- >>> matching _Just (Just 12)
-- Right 12
--
-- >>> matching _Just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int
-- Left Nothing
matching :: APrism s t a b -> s -> Either t a
matching k = withPrism k $ \_ seta -> seta
{-# INLINE matching #-}
------------------------------------------------------------------------------
-- Common Prisms
------------------------------------------------------------------------------
-- | This 'Prism' provides a 'Traversal' for tweaking the 'Left' half of an 'Either':
--
-- >>> over _Left (+1) (Left 2)
-- Left 3
--
-- >>> over _Left (+1) (Right 2)
-- Right 2
--
-- >>> Right 42 ^._Left :: String
-- ""
--
-- >>> Left "hello" ^._Left
-- "hello"
--
-- It also can be turned around to obtain the embedding into the 'Left' half of an 'Either':
--
-- >>> _Left # 5
-- Left 5
--
-- >>> 5^.re _Left
-- Left 5
_Left :: Prism (Either a c) (Either b c) a b
_Left = prism Left $ either Right (Left . Right)
{-# INLINE _Left #-}
-- | This 'Prism' provides a 'Traversal' for tweaking the 'Right' half of an 'Either':
--
-- >>> over _Right (+1) (Left 2)
-- Left 2
--
-- >>> over _Right (+1) (Right 2)
-- Right 3
--
-- >>> Right "hello" ^._Right
-- "hello"
--
-- >>> Left "hello" ^._Right :: [Double]
-- []
--
-- It also can be turned around to obtain the embedding into the 'Right' half of an 'Either':
--
-- >>> _Right # 5
-- Right 5
--
-- >>> 5^.re _Right
-- Right 5
_Right :: Prism (Either c a) (Either c b) a b
_Right = prism Right $ either (Left . Left) Right
{-# INLINE _Right #-}
-- | This 'Prism' provides a 'Traversal' for tweaking the target of the value of 'Just' in a 'Maybe'.
--
-- >>> over _Just (+1) (Just 2)
-- Just 3
--
-- Unlike 'Data.Traversable.traverse' this is a 'Prism', and so you can use it to inject as well:
--
-- >>> _Just # 5
-- Just 5
--
-- >>> 5^.re _Just
-- Just 5
--
-- Interestingly,
--
-- @
-- m '^?' '_Just' ≡ m
-- @
--
-- >>> Just x ^? _Just
-- Just x
--
-- >>> Nothing ^? _Just
-- Nothing
_Just :: Prism (Maybe a) (Maybe b) a b
_Just = prism Just $ maybe (Left Nothing) Right
{-# INLINE _Just #-}
-- | This 'Prism' provides the 'Traversal' of a 'Nothing' in a 'Maybe'.
--
-- >>> Nothing ^? _Nothing
-- Just ()
--
-- >>> Just () ^? _Nothing
-- Nothing
--
-- But you can turn it around and use it to construct 'Nothing' as well:
--
-- >>> _Nothing # ()
-- Nothing
_Nothing :: Prism' (Maybe a) ()
_Nothing = prism' (const Nothing) $ maybe (Just ()) (const Nothing)
{-# INLINE _Nothing #-}
-- | 'Void' is a logically uninhabited data type.
--
-- This is a 'Prism' that will always fail to match.
_Void :: Prism s s a Void
_Void = prism absurd Left
{-# INLINE _Void #-}
-- | This 'Prism' compares for exact equality with a given value.
--
-- >>> only 4 # ()
-- 4
--
-- >>> 5 ^? only 4
-- Nothing
only :: Eq a => a -> Prism' a ()
only a = prism' (\() -> a) $ guard . (a ==)
{-# INLINE only #-}
-- | This 'Prism' compares for approximate equality with a given value and a predicate for testing,
-- an example where the value is the empty list and the predicate checks that a list is empty (same
-- as 'Control.Lens.Empty._Empty' with the 'Control.Lens.Empty.AsEmpty' list instance):
--
-- >>> nearly [] null # ()
-- []
-- >>> [1,2,3,4] ^? nearly [] null
-- Nothing
--
-- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@
--
-- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are somewhat constrained.
--
-- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid 'Prism'.
--
-- This is useful when working with a type where you can test equality for only a subset of its
-- values, and the prism selects such a value.
nearly :: a -> (a -> Bool) -> Prism' a ()
nearly a p = prism' (\() -> a) $ guard . p
{-# INLINE nearly #-}
-- | This is an improper prism for text formatting based on 'Read' and 'Show'.
--
-- This 'Prism' is \"improper\" in the sense that it normalizes the text formatting, but round tripping
-- is idempotent given sane 'Read'/'Show' instances.
--
-- >>> _Show # 2
-- "2"
--
-- >>> "EQ" ^? _Show :: Maybe Ordering
-- Just EQ
--
-- @
-- '_Show' ≡ 'prism'' 'show' 'readMaybe'
-- @
_Show :: (Read a, Show a) => Prism' String a
_Show = prism show $ \s -> case reads s of
[(a,"")] -> Right a
_ -> Left s
{-# INLINE _Show #-}