diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,25 @@ +0.0.2 + +* Introduce the `One f a t` data type representing a value with a + distinguished head element and a functorial rest +* Split into two parallel class hierarchies: + - `*OneItem` classes (`GetterOneItem`, `HasOneItem`, `ReviewOneItem`, + `AsOneItem`): optics to/from the singleton element of a container + - `*One` classes (`GetterOne`, `HasOne`, `ReviewOne`, `AsOne`): optics + to/from the `One` data type, defined in `Control.One.One` +* Add instances for `Identity`, `NonEmpty`, `[]`, `Text` (strict, lazy, + short), tuples, and newtypes (`First`, `Last`, `Dual`, `Down`, `Sum`, + `Product`, `Min`, `Max`, `WrappedMonoid`, `Par1`, `Solo`, `Const`) +* Add `Bifunctor`, `Biapply`, `Biapplicative`, `Bifoldable`, + `Bitraversable`, `Bifoldable1`, `Bitraversable1`, `Foldable1`, and + `Traversable1` instances for `One` +* Add `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Show1`, `Show2` instances for `One` +* Add named optics: `identity`, `nonEmpty`, `list`, `text`, `lazyText`, + `shortText`, `first'`, `last'`, `dual`, `down`, `sum'`, `product'`, + `min'`, `max'`, `wrappedMonoid`, `par1`, `solo`, `const'`, `tuple` +* Add `bifunctors`, `text-short`, and `semigroupoids` as dependencies +* Remove unused `comonad` dependency + 0.0.1 * This change log starts diff --git a/one.cabal b/one.cabal --- a/one.cabal +++ b/one.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: one -version: 0.0.1 +version: 0.0.2 synopsis: One description: Data types that have a singleton view license: BSD-3-Clause @@ -22,18 +22,22 @@ library exposed-modules: Control.One - Control.One.AsOne - Control.One.GetterOne - Control.One.HasOne - Control.One.ReviewOne + Control.One.One + Control.One.AsOneItem + Control.One.GetterOneItem + Control.One.HasOneItem + Control.One.ReviewOneItem build-depends: base >= 4.8 && < 6 , lens >= 4 && < 6 + , bifunctors >= 5 && < 6 , text >= 1.2 && < 3 + , text-short >= 0.1.4 && < 1 , containers >= 0.5 && < 1 , unordered-containers >= 0.2 && < 1 , hashable >= 1.2 && < 2 , bytestring >= 0.10 && < 1 + , semigroupoids >= 5 && < 7 hs-source-dirs: src diff --git a/src/Control/One.hs b/src/Control/One.hs --- a/src/Control/One.hs +++ b/src/Control/One.hs @@ -8,73 +8,114 @@ -- -- Many data types have a natural notion of containing \"exactly one\" element. -- A 'Data.List.NonEmpty.NonEmpty' list always has a head. An 'Data.Functor.Identity.Identity' always wraps a single --- value. A 'Data.Set.Set' might contain exactly one element. This library captures --- these patterns with four type classes, arranged in two parallel hierarchies --- corresponding to the lens and prism sides: +-- value. A 'Data.Set.Set' might contain exactly one element. -- +-- This library provides two parallel class hierarchies: +-- +-- * __@*OneItem@ classes__ — optics to\/from the singleton /element/ of a container +-- * __@*One@ classes__ — optics to\/from the 'One' data type, which separates a +-- distinguished head element from a functorial rest +-- +-- == The @One@ data type +-- -- @ --- 'GetterOne' 'ReviewOne' --- | | --- 'HasOne' 'AsOne' +-- data 'One' f a t = 'One' a (f t) +-- type 'One'' f x = 'One' f x x -- @ -- --- === Lens hierarchy (total access) +-- @'One' f a t@ represents a value with a distinguished head @a@ and a +-- functorial rest @f t@. For example: -- --- For types that /always/ contain exactly one element: +-- * @'Data.List.NonEmpty.NonEmpty' a@ is isomorphic to @'One' [] a a@ +-- * @'Data.Functor.Identity.Identity' a@ is isomorphic to @'One' 'Data.Proxy.Proxy' a ()@ +-- * @'Data.Text.Text'@ decomposes as @'One' ('Data.Functor.Const.Const' 'Data.Text.Text') 'Char' ()@ +-- * @(x, a)@ is isomorphic to @'One' ('Data.Functor.Const.Const' x) a ()@ -- --- * 'GetterOne' — provides @'getOne' :: 'Control.Lens.Getter' x ('GetterOneItem' x)@ to --- extract the element. --- * 'HasOne' (superclass: 'GetterOne') — provides @'one' :: 'Control.Lens.Lens'' x ('OneItem' x)@ --- to both get and set the element. A default implementation is derived from --- 'getOne' and 'setOne'. +-- 'One' has instances for 'Data.Bifunctor.Bifunctor', 'Data.Bifunctor.Apply.Biapply', +-- 'Data.Biapplicative.Biapplicative', 'Data.Bifoldable.Bifoldable', +-- 'Data.Bitraversable.Bitraversable', 'Data.Semigroup.Bifoldable.Bifoldable1', +-- 'Data.Semigroup.Bitraversable.Bitraversable1', 'Data.Semigroup.Foldable.Foldable1', +-- and 'Data.Semigroup.Traversable.Traversable1'. -- --- === Prism hierarchy (partial access) +-- == @*OneItem@ classes — optics to\/from the element -- --- For types that /might/ contain exactly one element: +-- @ +-- 'GetterOneItem' 'ReviewOneItem' +-- | | +-- 'HasOneItem' 'AsOneItem' +-- @ -- --- * 'ReviewOne' — provides @'reviewOne' :: 'Control.Lens.Review' x ('ReviewOneItem' x)@ to +-- * 'GetterOneItem' — provides @'getOneItem' :: 'Control.Lens.Getter' x ('GetterOneItemElement' x)@ to +-- extract the element. +-- * 'HasOneItem' (superclass: 'GetterOneItem') — provides @'oneItem' :: 'Control.Lens.Lens'' x ('HasOneItemElement' x)@ +-- to both get and set the element. A default implementation is derived from +-- 'getOneItem' and 'setOneItem'. +-- * 'ReviewOneItem' — provides @'reviewOneItem' :: 'Control.Lens.Review' x ('ReviewOneItemElement' x)@ to -- construct a singleton value from an element. --- * 'AsOne' (superclass: 'ReviewOne') — provides @'_One' :: 'Control.Lens.Prism'' x ('AsOneItem' x)@ +-- * 'AsOneItem' (superclass: 'ReviewOneItem') — provides @'_OneItem' :: 'Control.Lens.Prism'' x ('AsOneItemElement' x)@ -- to both construct and pattern-match singleton values. A default --- implementation is derived from 'reviewOne' and 'matchOne'. +-- implementation is derived from 'reviewOneItem' and 'matchOneItem'. -- +-- == @*One@ classes — optics to\/from the @One@ data type +-- +-- @ +-- 'GetterOne' 'ReviewOne' +-- | | +-- 'HasOne' 'AsOne' +-- @ +-- +-- * 'GetterOne' — provides @'getOne' :: 'Control.Lens.Getter' x ('One' f a t)@ +-- * 'HasOne' (superclass: 'GetterOne') — provides @'one' :: 'Control.Lens.Lens'' x ('One' f a t)@ +-- and @'rest' :: 'Control.Lens.Lens'' x (f t)@ +-- * 'ReviewOne' — provides @'reviewOne' :: 'Control.Lens.Review' x ('One' f a t)@ +-- * 'AsOne' (superclass: 'ReviewOne') — provides @'_One' :: 'Control.Lens.Prism'' x ('One' f a t)@. +-- A default implementation is derived from 'reviewOne' and 'matchOne'. +-- +-- These use functional dependencies (@| x -> f a t@) to determine the +-- functor, head, and tail types. +-- -- == Usage -- --- === Constructing singleton values +-- === Working with the @One@ decomposition -- -- >>> import Control.Lens (preview, review, set, view) -- >>> import Data.Functor.Identity (Identity(..)) -- >>> import Data.List.NonEmpty (NonEmpty(..)) -- >>> import Data.Set (Set) --- >>> review reviewOne 7 :: [Int] --- [7] +-- >>> import qualified Data.Text as Text +-- >>> view one (1 :| [2, 3]) :: One [] Int Int +-- One 1 [2,3] -- --- >>> review reviewOne 7 :: Set Int --- fromList [7] +-- >>> set one (One 9 [10]) (1 :| [2, 3]) +-- 9 :| [10] -- --- >>> review _One 7 :: Maybe Int --- Just 7 +-- >>> view rest (1 :| [2, 3]) +-- [2,3] -- --- === Matching singleton values +-- >>> preview _One (Text.pack "hi") :: Maybe (One (Data.Functor.Const.Const Text.Text) Char ()) +-- Just (One 'h' (Const "i")) -- --- >>> preview _One [7] --- Just 7 +-- === Working with singleton elements (@*OneItem@) -- --- >>> preview _One [1, 2] --- Nothing +-- >>> review reviewOneItem 7 :: [Int] +-- [7] -- --- >>> preview _One (Nothing :: Maybe Int) --- Nothing +-- >>> review reviewOneItem 7 :: Set Int +-- fromList [7] -- --- === Getting and setting (total types) +-- >>> preview _OneItem [7] +-- Just 7 -- --- >>> view one (1 :| [2, 3]) +-- >>> preview _OneItem [1, 2] +-- Nothing +-- +-- >>> view oneItem (1 :| [2, 3]) -- 1 -- --- >>> set one 9 (1 :| [2, 3]) +-- >>> set oneItem 9 (1 :| [2, 3]) -- 9 :| [2,3] -- --- >>> view one (Identity 7) +-- >>> view oneItem (Identity 7) -- 7 -- -- == Instances @@ -84,8 +125,8 @@ -- * __Containers__: @[]@, 'Data.List.NonEmpty.NonEmpty', 'Data.Sequence.Seq', -- 'Data.Set.Set', 'Data.Map.Map', 'Data.IntSet.IntSet', 'Data.IntMap.IntMap', -- 'Data.HashSet.HashSet', 'Data.HashMap.Strict.HashMap' --- * __Text and bytes__: 'Data.Text.Text', 'Data.ByteString.ByteString' --- (strict, lazy, and short variants) +-- * __Text and bytes__: 'Data.Text.Text', @Data.Text.Lazy.Text@, @Data.Text.Short.ShortText@, +-- 'Data.ByteString.ByteString' (strict, lazy, and short variants) -- * __Maybe and Either__: 'Maybe', 'Either' -- * __Newtypes__: 'Data.Functor.Identity.Identity', 'Data.Functor.Const.Const', -- 'Data.Semigroup.First', 'Data.Semigroup.Last', 'Data.Semigroup.Min', @@ -95,12 +136,14 @@ -- * __Tuples__: @(x, a)@ -- -- Types that always contain one element (e.g. 'Data.Functor.Identity.Identity', --- 'Data.List.NonEmpty.NonEmpty', 'Data.Tuple.Solo') have instances for all four classes. --- Types that might contain one element (e.g. @[]@, 'Maybe', 'Data.Set.Set') --- have instances only for the prism side ('ReviewOne' and 'AsOne'). +-- 'Data.List.NonEmpty.NonEmpty', 'Data.Tuple.Solo') have instances for all four classes +-- in both hierarchies. Types that might contain one element (e.g. @[]@, 'Maybe', +-- 'Data.Set.Set') have instances only for the prism side ('ReviewOneItem' \/ 'AsOneItem' +-- and 'ReviewOne' \/ 'AsOne'). module Control.One (module O) where -import Control.One.AsOne as O -import Control.One.GetterOne as O -import Control.One.HasOne as O -import Control.One.ReviewOne as O +import Control.One.AsOneItem as O +import Control.One.GetterOneItem as O +import Control.One.HasOneItem as O +import Control.One.One as O +import Control.One.ReviewOneItem as O diff --git a/src/Control/One/AsOne.hs b/src/Control/One/AsOne.hs deleted file mode 100644 --- a/src/Control/One/AsOne.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wall -Werror #-} - -module Control.One.AsOne where - -import Control.Applicative (Const (..), ZipList (..)) -import Control.Lens (Prism', preview, prism', review, view, _Just, _Right, _Wrapped) -import Control.One.ReviewOne (ReviewOne (ReviewOneItem, reviewOne)) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.ByteString.Short as ShortByteString -import Data.Functor.Identity (Identity (..)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Hashable (Hashable) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Ord (Down (..)) -import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) -import Data.Sequence (Seq, pattern (:<|)) -import qualified Data.Sequence as Sequence -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import Data.Tuple (Solo (..)) -import Data.Word (Word8) -import GHC.Generics (Par1 (..)) - -class (ReviewOne x) => AsOne x where - type AsOneItem x - - matchOne :: x -> Maybe (AsOneItem x) - - _One :: Prism' x (AsOneItem x) - default _One :: (ReviewOneItem x ~ AsOneItem x) => Prism' x (AsOneItem x) - _One = prism' (review reviewOne) matchOne - --- | >>> preview _One [7] --- Just 7 --- --- >>> preview _One [1, 2] --- Nothing --- --- >>> preview _One ([] :: [Int]) --- Nothing --- --- >>> review _One 7 :: [Int] --- [7] -instance AsOne [a] where - type AsOneItem [a] = a - - matchOne = \case - [a] -> Just a - _ -> Nothing - --- | >>> preview _One (7 :| []) --- Just 7 --- --- >>> preview _One (1 :| [2]) --- Nothing --- --- >>> review _One 7 :: NonEmpty Int --- 7 :| [] -instance AsOne (NonEmpty a) where - type AsOneItem (NonEmpty a) = a - - matchOne = \case - a :| [] -> Just a - _ -> Nothing - --- | >>> preview _One (Sequence.singleton 7) --- Just 7 --- --- >>> preview _One (Sequence.fromList [1, 2]) --- Nothing --- --- >>> preview _One Sequence.empty --- Nothing --- --- >>> review _One 7 :: Seq Int --- fromList [7] -instance AsOne (Seq a) where - type AsOneItem (Seq a) = a - - matchOne = \case - a :<| Sequence.Empty -> Just a - _ -> Nothing - --- | >>> preview _One (Text.singleton 'a') --- Just 'a' --- --- >>> preview _One (Text.pack "ab") --- Nothing --- --- >>> preview _One Text.empty --- Nothing --- --- >>> review _One 'a' :: Text.Text --- "a" -instance AsOne Text.Text where - type AsOneItem Text.Text = Char - - matchOne x = case Text.uncons x of - Just (c, rest) | Text.null rest -> Just c - _ -> Nothing - --- | >>> preview _One (LazyText.singleton 'a') --- Just 'a' --- --- >>> preview _One (LazyText.pack "ab") --- Nothing --- --- >>> review _One 'a' :: LazyText.Text --- "a" -instance AsOne LazyText.Text where - type AsOneItem LazyText.Text = Char - - matchOne x = case LazyText.uncons x of - Just (c, rest) | LazyText.null rest -> Just c - _ -> Nothing - --- | >>> preview _One (ByteString.singleton 65) --- Just 65 --- --- >>> preview _One (ByteString.pack [1, 2]) --- Nothing --- --- >>> preview _One ByteString.empty --- Nothing --- --- >>> review _One 65 :: ByteString.ByteString --- "A" -instance AsOne ByteString.ByteString where - type AsOneItem ByteString.ByteString = Word8 - - matchOne x = case ByteString.uncons x of - Just (w, rest) | ByteString.null rest -> Just w - _ -> Nothing - --- | >>> preview _One (LazyByteString.singleton 65) --- Just 65 --- --- >>> preview _One (LazyByteString.pack [1, 2]) --- Nothing --- --- >>> review _One 65 :: LazyByteString.ByteString --- "A" -instance AsOne LazyByteString.ByteString where - type AsOneItem LazyByteString.ByteString = Word8 - - matchOne x = case LazyByteString.uncons x of - Just (w, rest) | LazyByteString.null rest -> Just w - _ -> Nothing - --- | >>> preview _One (ShortByteString.singleton 65) --- Just 65 --- --- >>> preview _One (ShortByteString.pack [1, 2]) --- Nothing --- --- >>> review _One 65 :: ShortByteString.ShortByteString --- "A" -instance AsOne ShortByteString.ShortByteString where - type AsOneItem ShortByteString.ShortByteString = Word8 - - matchOne x = - if ShortByteString.length x == 1 then Just (ShortByteString.index x 0) else Nothing - --- | >>> preview _One (Map.singleton "key" (7 :: Int)) --- Just ("key",7) --- --- >>> preview _One (Map.fromList [("a", 1), ("b", 2)] :: Map String Int) --- Nothing --- --- >>> review _One ("key", 7) :: Map String Int --- fromList [("key",7)] -instance AsOne (Map k v) where - type AsOneItem (Map k v) = (k, v) - - matchOne x = - if Map.size x == 1 then Just (Map.findMin x) else Nothing - --- | >>> preview _One (HashMap.singleton "key" (7 :: Int)) --- Just ("key",7) --- --- >>> review _One ("key", 7) :: HashMap String Int --- fromList [("key",7)] -instance (Hashable k) => AsOne (HashMap k v) where - type AsOneItem (HashMap k v) = (k, v) - - matchOne x = - case HashMap.toList x of - [kv] -> Just kv - _ -> Nothing - --- | >>> preview _One (IntMap.singleton 1 7) --- Just (1,7) --- --- >>> preview _One (IntMap.fromList [(1, 2), (3, 4)]) --- Nothing --- --- >>> review _One (1, 7) :: IntMap Int --- fromList [(1,7)] -instance AsOne (IntMap v) where - type AsOneItem (IntMap v) = (Int, v) - - matchOne x = - if IntMap.size x == 1 then Just (IntMap.findMin x) else Nothing - --- | >>> preview _One (Set.singleton 7) --- Just 7 --- --- >>> preview _One (Set.fromList [1, 2]) --- Nothing --- --- >>> review _One 7 :: Set Int --- fromList [7] -instance AsOne (Set a) where - type AsOneItem (Set a) = a - - matchOne x = - if Set.size x == 1 then Just (Set.findMin x) else Nothing - --- | >>> preview _One (HashSet.singleton 7) --- Just 7 --- --- >>> review _One 7 :: HashSet Int --- fromList [7] -instance (Hashable a) => AsOne (HashSet a) where - type AsOneItem (HashSet a) = a - - matchOne x = - case HashSet.toList x of - [a] -> Just a - _ -> Nothing - --- | >>> preview _One (IntSet.singleton 7) --- Just 7 --- --- >>> preview _One (IntSet.fromList [1, 2]) --- Nothing --- --- >>> review _One 7 :: IntSet --- fromList [7] -instance AsOne IntSet where - type AsOneItem IntSet = Int - - matchOne x = - if IntSet.size x == 1 then Just (IntSet.findMin x) else Nothing - --- | >>> preview _One ("", 7 :: Int) :: Maybe Int --- Just 7 --- --- >>> preview _One ("nonempty", 7 :: Int) :: Maybe Int --- Nothing --- --- >>> review _One 7 :: (String, Int) --- ("",7) -instance (Eq a, Monoid a) => AsOne (a, b) where - type AsOneItem (a, b) = b - - matchOne = \case - (a, b) -> if a == mempty then Just b else Nothing - --- | >>> preview _One (Just 7) --- Just 7 --- --- >>> preview _One (Nothing :: Maybe Int) --- Nothing --- --- >>> review _One 7 :: Maybe Int --- Just 7 -instance AsOne (Maybe a) where - type AsOneItem (Maybe a) = a - - matchOne = - preview _Just - {-# INLINE matchOne #-} - --- | >>> preview _One (Right 7 :: Either String Int) --- Just 7 --- --- >>> preview _One (Left "err" :: Either String Int) --- Nothing --- --- >>> review _One 7 :: Either String Int --- Right 7 -instance AsOne (Either a b) where - type AsOneItem (Either a b) = b - - matchOne = - preview _Right - {-# INLINE matchOne #-} - --- | >>> preview _One (Identity 7) --- Just 7 --- --- >>> review _One 7 :: Identity Int --- Identity 7 -instance AsOne (Identity a) where - type AsOneItem (Identity a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Const 7 :: Const Int String) --- Just 7 --- --- >>> review _One 7 :: Const Int String --- Const 7 -instance AsOne (Const a b) where - type AsOneItem (Const a b) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (First 7) --- Just 7 --- --- >>> review _One 7 :: First Int --- First {getFirst = 7} -instance AsOne (First a) where - type AsOneItem (First a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Last 7) --- Just 7 --- --- >>> review _One 7 :: Last Int --- Last {getLast = 7} -instance AsOne (Last a) where - type AsOneItem (Last a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (WrapMonoid 7) --- Just 7 --- --- >>> review _One 7 :: WrappedMonoid Int --- WrapMonoid {unwrapMonoid = 7} -instance AsOne (WrappedMonoid a) where - type AsOneItem (WrappedMonoid a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Dual 7) --- Just 7 --- --- >>> review _One 7 :: Dual Int --- Dual {getDual = 7} -instance AsOne (Dual a) where - type AsOneItem (Dual a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Down 7) --- Just 7 --- --- >>> review _One 7 :: Down Int --- Down 7 -instance AsOne (Down a) where - type AsOneItem (Down a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Sum 7) --- Just 7 --- --- >>> review _One 7 :: Sum Int --- Sum {getSum = 7} -instance AsOne (Sum a) where - type AsOneItem (Sum a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Product 7) --- Just 7 --- --- >>> review _One 7 :: Product Int --- Product {getProduct = 7} -instance AsOne (Product a) where - type AsOneItem (Product a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Min 7) --- Just 7 --- --- >>> review _One 7 :: Min Int --- Min {getMin = 7} -instance AsOne (Min a) where - type AsOneItem (Min a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Max 7) --- Just 7 --- --- >>> review _One 7 :: Max Int --- Max {getMax = 7} -instance AsOne (Max a) where - type AsOneItem (Max a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (ZipList [7]) --- Just 7 --- --- >>> preview _One (ZipList [1, 2]) --- Nothing --- --- >>> preview _One (ZipList ([] :: [Int])) --- Nothing --- --- >>> review _One 7 :: ZipList Int --- ZipList {getZipList = [7]} -instance AsOne (ZipList a) where - type AsOneItem (ZipList a) = a - - matchOne = - matchOne . view _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (Par1 7) --- Just 7 --- --- >>> review _One 7 :: Par1 Int --- Par1 {unPar1 = 7} -instance AsOne (Par1 a) where - type AsOneItem (Par1 a) = a - - matchOne = - preview _Wrapped - {-# INLINE matchOne #-} - --- | >>> preview _One (MkSolo 7) --- Just 7 --- --- >>> review _One 7 :: Solo Int --- MkSolo 7 -instance AsOne (Solo a) where - type AsOneItem (Solo a) = a - - matchOne (MkSolo x) = Just x - {-# INLINE matchOne #-} diff --git a/src/Control/One/AsOneItem.hs b/src/Control/One/AsOneItem.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/AsOneItem.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Control.One.AsOneItem where + +import Control.Applicative (Const (..), ZipList (..)) +import Control.Lens (Prism', preview, prism', review, view, _Just, _Right, _Wrapped) +import Control.One.ReviewOneItem (ReviewOneItem (ReviewOneItemElement, reviewOneItem)) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.ByteString.Short as ShortByteString +import Data.Functor.Identity (Identity (..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord (Down (..)) +import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) +import Data.Sequence (Seq, pattern (:<|)) +import qualified Data.Sequence as Sequence +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Short as ShortText +import Data.Tuple (Solo (..)) +import Data.Word (Word8) +import GHC.Generics (Par1 (..)) + +class (ReviewOneItem x) => AsOneItem x where + type AsOneItemElement x + + matchOneItem :: x -> Maybe (AsOneItemElement x) + + _OneItem :: Prism' x (AsOneItemElement x) + default _OneItem :: (ReviewOneItemElement x ~ AsOneItemElement x) => Prism' x (AsOneItemElement x) + _OneItem = prism' (review reviewOneItem) matchOneItem + +-- | >>> preview _OneItem [7] +-- Just 7 +-- +-- >>> preview _OneItem [1, 2] +-- Nothing +-- +-- >>> preview _OneItem ([] :: [Int]) +-- Nothing +-- +-- >>> review _OneItem 7 :: [Int] +-- [7] +instance AsOneItem [a] where + type AsOneItemElement [a] = a + + matchOneItem = \case + [a] -> Just a + _ -> Nothing + +-- | >>> preview _OneItem (7 :| []) +-- Just 7 +-- +-- >>> preview _OneItem (1 :| [2]) +-- Nothing +-- +-- >>> review _OneItem 7 :: NonEmpty Int +-- 7 :| [] +instance AsOneItem (NonEmpty a) where + type AsOneItemElement (NonEmpty a) = a + + matchOneItem = \case + a :| [] -> Just a + _ -> Nothing + +-- | >>> preview _OneItem (Sequence.singleton 7) +-- Just 7 +-- +-- >>> preview _OneItem (Sequence.fromList [1, 2]) +-- Nothing +-- +-- >>> preview _OneItem Sequence.empty +-- Nothing +-- +-- >>> review _OneItem 7 :: Seq Int +-- fromList [7] +instance AsOneItem (Seq a) where + type AsOneItemElement (Seq a) = a + + matchOneItem = \case + a :<| Sequence.Empty -> Just a + _ -> Nothing + +-- | >>> preview _OneItem (Text.singleton 'a') +-- Just 'a' +-- +-- >>> preview _OneItem (Text.pack "ab") +-- Nothing +-- +-- >>> preview _OneItem Text.empty +-- Nothing +-- +-- >>> review _OneItem 'a' :: Text.Text +-- "a" +instance AsOneItem Text.Text where + type AsOneItemElement Text.Text = Char + + matchOneItem x = case Text.uncons x of + Just (c, rest) | Text.null rest -> Just c + _ -> Nothing + +-- | >>> preview _OneItem (LazyText.singleton 'a') +-- Just 'a' +-- +-- >>> preview _OneItem (LazyText.pack "ab") +-- Nothing +-- +-- >>> review _OneItem 'a' :: LazyText.Text +-- "a" +instance AsOneItem LazyText.Text where + type AsOneItemElement LazyText.Text = Char + + matchOneItem x = case LazyText.uncons x of + Just (c, rest) | LazyText.null rest -> Just c + _ -> Nothing + +-- | >>> preview _OneItem (ShortText.singleton 'a') +-- Just 'a' +-- +-- >>> preview _OneItem (ShortText.pack "ab") +-- Nothing +-- +-- >>> preview _OneItem (ShortText.pack "") +-- Nothing +-- +-- >>> review _OneItem 'a' :: ShortText.ShortText +-- "a" +instance AsOneItem ShortText.ShortText where + type AsOneItemElement ShortText.ShortText = Char + + matchOneItem x = case ShortText.uncons x of + Just (c, rest) | ShortText.null rest -> Just c + _ -> Nothing + +-- | >>> preview _OneItem (ByteString.singleton 65) +-- Just 65 +-- +-- >>> preview _OneItem (ByteString.pack [1, 2]) +-- Nothing +-- +-- >>> preview _OneItem ByteString.empty +-- Nothing +-- +-- >>> review _OneItem 65 :: ByteString.ByteString +-- "A" +instance AsOneItem ByteString.ByteString where + type AsOneItemElement ByteString.ByteString = Word8 + + matchOneItem x = case ByteString.uncons x of + Just (w, rest) | ByteString.null rest -> Just w + _ -> Nothing + +-- | >>> preview _OneItem (LazyByteString.singleton 65) +-- Just 65 +-- +-- >>> preview _OneItem (LazyByteString.pack [1, 2]) +-- Nothing +-- +-- >>> review _OneItem 65 :: LazyByteString.ByteString +-- "A" +instance AsOneItem LazyByteString.ByteString where + type AsOneItemElement LazyByteString.ByteString = Word8 + + matchOneItem x = case LazyByteString.uncons x of + Just (w, rest) | LazyByteString.null rest -> Just w + _ -> Nothing + +-- | >>> preview _OneItem (ShortByteString.singleton 65) +-- Just 65 +-- +-- >>> preview _OneItem (ShortByteString.pack [1, 2]) +-- Nothing +-- +-- >>> review _OneItem 65 :: ShortByteString.ShortByteString +-- "A" +instance AsOneItem ShortByteString.ShortByteString where + type AsOneItemElement ShortByteString.ShortByteString = Word8 + + matchOneItem x = + if ShortByteString.length x == 1 then Just (ShortByteString.index x 0) else Nothing + +-- | >>> preview _OneItem (Map.singleton "key" (7 :: Int)) +-- Just ("key",7) +-- +-- >>> preview _OneItem (Map.fromList [("a", 1), ("b", 2)] :: Map String Int) +-- Nothing +-- +-- >>> review _OneItem ("key", 7) :: Map String Int +-- fromList [("key",7)] +instance AsOneItem (Map k v) where + type AsOneItemElement (Map k v) = (k, v) + + matchOneItem x = + if Map.size x == 1 then Just (Map.findMin x) else Nothing + +-- | >>> preview _OneItem (HashMap.singleton "key" (7 :: Int)) +-- Just ("key",7) +-- +-- >>> review _OneItem ("key", 7) :: HashMap String Int +-- fromList [("key",7)] +instance (Hashable k) => AsOneItem (HashMap k v) where + type AsOneItemElement (HashMap k v) = (k, v) + + matchOneItem x = + case HashMap.toList x of + [kv] -> Just kv + _ -> Nothing + +-- | >>> preview _OneItem (IntMap.singleton 1 7) +-- Just (1,7) +-- +-- >>> preview _OneItem (IntMap.fromList [(1, 2), (3, 4)]) +-- Nothing +-- +-- >>> review _OneItem (1, 7) :: IntMap Int +-- fromList [(1,7)] +instance AsOneItem (IntMap v) where + type AsOneItemElement (IntMap v) = (Int, v) + + matchOneItem x = + if IntMap.size x == 1 then Just (IntMap.findMin x) else Nothing + +-- | >>> preview _OneItem (Set.singleton 7) +-- Just 7 +-- +-- >>> preview _OneItem (Set.fromList [1, 2]) +-- Nothing +-- +-- >>> review _OneItem 7 :: Set Int +-- fromList [7] +instance AsOneItem (Set a) where + type AsOneItemElement (Set a) = a + + matchOneItem x = + if Set.size x == 1 then Just (Set.findMin x) else Nothing + +-- | >>> preview _OneItem (HashSet.singleton 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: HashSet Int +-- fromList [7] +instance (Hashable a) => AsOneItem (HashSet a) where + type AsOneItemElement (HashSet a) = a + + matchOneItem x = + case HashSet.toList x of + [a] -> Just a + _ -> Nothing + +-- | >>> preview _OneItem (IntSet.singleton 7) +-- Just 7 +-- +-- >>> preview _OneItem (IntSet.fromList [1, 2]) +-- Nothing +-- +-- >>> review _OneItem 7 :: IntSet +-- fromList [7] +instance AsOneItem IntSet where + type AsOneItemElement IntSet = Int + + matchOneItem x = + if IntSet.size x == 1 then Just (IntSet.findMin x) else Nothing + +-- | >>> preview _OneItem ("", 7 :: Int) :: Maybe Int +-- Just 7 +-- +-- >>> preview _OneItem ("nonempty", 7 :: Int) :: Maybe Int +-- Nothing +-- +-- >>> review _OneItem 7 :: (String, Int) +-- ("",7) +instance (Eq a, Monoid a) => AsOneItem (a, b) where + type AsOneItemElement (a, b) = b + + matchOneItem = \case + (a, b) -> if a == mempty then Just b else Nothing + +-- | >>> preview _OneItem (Just 7) +-- Just 7 +-- +-- >>> preview _OneItem (Nothing :: Maybe Int) +-- Nothing +-- +-- >>> review _OneItem 7 :: Maybe Int +-- Just 7 +instance AsOneItem (Maybe a) where + type AsOneItemElement (Maybe a) = a + + matchOneItem = + preview _Just + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Right 7 :: Either String Int) +-- Just 7 +-- +-- >>> preview _OneItem (Left "err" :: Either String Int) +-- Nothing +-- +-- >>> review _OneItem 7 :: Either String Int +-- Right 7 +instance AsOneItem (Either a b) where + type AsOneItemElement (Either a b) = b + + matchOneItem = + preview _Right + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Identity 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Identity Int +-- Identity 7 +instance AsOneItem (Identity a) where + type AsOneItemElement (Identity a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Const 7 :: Const Int String) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Const Int String +-- Const 7 +instance AsOneItem (Const a b) where + type AsOneItemElement (Const a b) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (First 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: First Int +-- First {getFirst = 7} +instance AsOneItem (First a) where + type AsOneItemElement (First a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Last 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Last Int +-- Last {getLast = 7} +instance AsOneItem (Last a) where + type AsOneItemElement (Last a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (WrapMonoid 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: WrappedMonoid Int +-- WrapMonoid {unwrapMonoid = 7} +instance AsOneItem (WrappedMonoid a) where + type AsOneItemElement (WrappedMonoid a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Dual 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Dual Int +-- Dual {getDual = 7} +instance AsOneItem (Dual a) where + type AsOneItemElement (Dual a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Down 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Down Int +-- Down 7 +instance AsOneItem (Down a) where + type AsOneItemElement (Down a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Sum 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Sum Int +-- Sum {getSum = 7} +instance AsOneItem (Sum a) where + type AsOneItemElement (Sum a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Product 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Product Int +-- Product {getProduct = 7} +instance AsOneItem (Product a) where + type AsOneItemElement (Product a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Min 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Min Int +-- Min {getMin = 7} +instance AsOneItem (Min a) where + type AsOneItemElement (Min a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Max 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Max Int +-- Max {getMax = 7} +instance AsOneItem (Max a) where + type AsOneItemElement (Max a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (ZipList [7]) +-- Just 7 +-- +-- >>> preview _OneItem (ZipList [1, 2]) +-- Nothing +-- +-- >>> preview _OneItem (ZipList ([] :: [Int])) +-- Nothing +-- +-- >>> review _OneItem 7 :: ZipList Int +-- ZipList {getZipList = [7]} +instance AsOneItem (ZipList a) where + type AsOneItemElement (ZipList a) = a + + matchOneItem = + matchOneItem . view _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (Par1 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Par1 Int +-- Par1 {unPar1 = 7} +instance AsOneItem (Par1 a) where + type AsOneItemElement (Par1 a) = a + + matchOneItem = + preview _Wrapped + {-# INLINE matchOneItem #-} + +-- | >>> preview _OneItem (MkSolo 7) +-- Just 7 +-- +-- >>> review _OneItem 7 :: Solo Int +-- MkSolo 7 +instance AsOneItem (Solo a) where + type AsOneItemElement (Solo a) = a + + matchOneItem (MkSolo x) = Just x + {-# INLINE matchOneItem #-} diff --git a/src/Control/One/GetterOne.hs b/src/Control/One/GetterOne.hs deleted file mode 100644 --- a/src/Control/One/GetterOne.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall -Werror #-} - -module Control.One.GetterOne where - -import Control.Applicative (Const (..)) -import Control.Lens (Getter, to, _Wrapped) -import Data.Functor.Identity (Identity (..)) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Ord (Down (..)) -import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) -import Data.Tuple (Solo (..)) -import GHC.Generics (Par1 (..)) - --- $setup --- >>> import Control.Lens (view) - -class GetterOne x where - type GetterOneItem x - - getOne :: Getter x (GetterOneItem x) - --- | >>> view getOne (1 :| [2, 3]) --- 1 -instance GetterOne (NonEmpty a) where - type GetterOneItem (NonEmpty a) = a - - getOne = to (\(a :| _) -> a) - --- | >>> view getOne ("hello", 42 :: Int) --- 42 -instance GetterOne (x, a) where - type GetterOneItem (x, a) = a - - getOne = to snd - --- | >>> view getOne (Identity 7) --- 7 -instance GetterOne (Identity a) where - type GetterOneItem (Identity a) = a - - getOne = _Wrapped - --- | >>> view getOne (Const 7 :: Const Int String) --- 7 -instance GetterOne (Const a b) where - type GetterOneItem (Const a b) = a - - getOne = _Wrapped - --- | >>> view getOne (First 7) --- 7 -instance GetterOne (First a) where - type GetterOneItem (First a) = a - - getOne = _Wrapped - --- | >>> view getOne (Last 7) --- 7 -instance GetterOne (Last a) where - type GetterOneItem (Last a) = a - - getOne = _Wrapped - --- | >>> view getOne (WrapMonoid "hello") --- "hello" -instance GetterOne (WrappedMonoid a) where - type GetterOneItem (WrappedMonoid a) = a - - getOne = _Wrapped - --- | >>> view getOne (Dual 7) --- 7 -instance GetterOne (Dual a) where - type GetterOneItem (Dual a) = a - - getOne = _Wrapped - --- | >>> view getOne (Down 7) --- 7 -instance GetterOne (Down a) where - type GetterOneItem (Down a) = a - - getOne = _Wrapped - --- | >>> view getOne (Sum 7) --- 7 -instance GetterOne (Sum a) where - type GetterOneItem (Sum a) = a - - getOne = _Wrapped - --- | >>> view getOne (Product 7) --- 7 -instance GetterOne (Product a) where - type GetterOneItem (Product a) = a - - getOne = _Wrapped - --- | >>> view getOne (Min 7) --- 7 -instance GetterOne (Min a) where - type GetterOneItem (Min a) = a - - getOne = _Wrapped - --- | >>> view getOne (Max 7) --- 7 -instance GetterOne (Max a) where - type GetterOneItem (Max a) = a - - getOne = _Wrapped - --- | >>> view getOne (Par1 7) --- 7 -instance GetterOne (Par1 a) where - type GetterOneItem (Par1 a) = a - - getOne = _Wrapped - --- | >>> view getOne (MkSolo 7) --- 7 -instance GetterOne (Solo a) where - type GetterOneItem (Solo a) = a - - getOne = to (\(MkSolo a) -> a) diff --git a/src/Control/One/GetterOneItem.hs b/src/Control/One/GetterOneItem.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/GetterOneItem.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Control.One.GetterOneItem where + +import Control.Applicative (Const (..)) +import Control.Lens (Getter, to, _Wrapped) +import Data.Functor.Identity (Identity (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Ord (Down (..)) +import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) +import Data.Tuple (Solo (..)) +import GHC.Generics (Par1 (..)) + +-- $setup +-- >>> import Control.Lens (view) + +class GetterOneItem x where + type GetterOneItemElement x + + getOneItem :: Getter x (GetterOneItemElement x) + +-- | >>> view getOneItem (1 :| [2, 3]) +-- 1 +instance GetterOneItem (NonEmpty a) where + type GetterOneItemElement (NonEmpty a) = a + + getOneItem = to (\(a :| _) -> a) + +-- | >>> view getOneItem ("hello", 42 :: Int) +-- 42 +instance GetterOneItem (x, a) where + type GetterOneItemElement (x, a) = a + + getOneItem = to snd + +-- | >>> view getOneItem (Identity 7) +-- 7 +instance GetterOneItem (Identity a) where + type GetterOneItemElement (Identity a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Const 7 :: Const Int String) +-- 7 +instance GetterOneItem (Const a b) where + type GetterOneItemElement (Const a b) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (First 7) +-- 7 +instance GetterOneItem (First a) where + type GetterOneItemElement (First a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Last 7) +-- 7 +instance GetterOneItem (Last a) where + type GetterOneItemElement (Last a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (WrapMonoid "hello") +-- "hello" +instance GetterOneItem (WrappedMonoid a) where + type GetterOneItemElement (WrappedMonoid a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Dual 7) +-- 7 +instance GetterOneItem (Dual a) where + type GetterOneItemElement (Dual a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Down 7) +-- 7 +instance GetterOneItem (Down a) where + type GetterOneItemElement (Down a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Sum 7) +-- 7 +instance GetterOneItem (Sum a) where + type GetterOneItemElement (Sum a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Product 7) +-- 7 +instance GetterOneItem (Product a) where + type GetterOneItemElement (Product a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Min 7) +-- 7 +instance GetterOneItem (Min a) where + type GetterOneItemElement (Min a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Max 7) +-- 7 +instance GetterOneItem (Max a) where + type GetterOneItemElement (Max a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (Par1 7) +-- 7 +instance GetterOneItem (Par1 a) where + type GetterOneItemElement (Par1 a) = a + + getOneItem = _Wrapped + +-- | >>> view getOneItem (MkSolo 7) +-- 7 +instance GetterOneItem (Solo a) where + type GetterOneItemElement (Solo a) = a + + getOneItem = to (\(MkSolo a) -> a) diff --git a/src/Control/One/HasOne.hs b/src/Control/One/HasOne.hs deleted file mode 100644 --- a/src/Control/One/HasOne.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wall -Werror #-} - -module Control.One.HasOne where - -import Control.Applicative (Const (..)) -import Control.Lens (Lens', lens, view) -import Control.One.GetterOne (GetterOne (GetterOneItem, getOne)) -import Data.Functor.Identity (Identity (..)) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Ord (Down (..)) -import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) -import Data.Tuple (Solo (..)) -import GHC.Generics (Par1 (..)) - --- $setup --- >>> import Control.Lens (set) - -class (GetterOne x) => HasOne x where - type OneItem x - - setOne :: x -> OneItem x -> x - - one :: Lens' x (OneItem x) - default one :: (GetterOneItem x ~ OneItem x) => Lens' x (OneItem x) - one = lens (view getOne) setOne - --- | >>> view one (1 :| [2, 3]) --- 1 --- --- >>> set one 9 (1 :| [2, 3]) --- 9 :| [2,3] -instance HasOne (NonEmpty a) where - type OneItem (NonEmpty a) = a - - setOne (_ :| xs) a = a :| xs - --- | >>> view one ("hello", 42 :: Int) --- 42 --- --- >>> set one 9 ("hello", 42 :: Int) --- ("hello",9) -instance HasOne (x, a) where - type OneItem (x, a) = a - - setOne (x, _) a = (x, a) - --- | >>> view one (Identity 7) --- 7 --- --- >>> set one 9 (Identity 7) --- Identity 9 -instance HasOne (Identity a) where - type OneItem (Identity a) = a - - setOne _ = Identity - --- | >>> view one (Const 7 :: Const Int String) --- 7 --- --- >>> set one 9 (Const 7 :: Const Int String) --- Const 9 -instance HasOne (Const a b) where - type OneItem (Const a b) = a - - setOne _ = Const - --- | >>> view one (First 7) --- 7 --- --- >>> set one 9 (First 7) --- First {getFirst = 9} -instance HasOne (First a) where - type OneItem (First a) = a - - setOne _ = First - --- | >>> view one (Last 7) --- 7 --- --- >>> set one 9 (Last 7) --- Last {getLast = 9} -instance HasOne (Last a) where - type OneItem (Last a) = a - - setOne _ = Last - --- | >>> view one (WrapMonoid "hello") --- "hello" --- --- >>> set one "world" (WrapMonoid "hello") --- WrapMonoid {unwrapMonoid = "world"} -instance HasOne (WrappedMonoid a) where - type OneItem (WrappedMonoid a) = a - - setOne _ = WrapMonoid - --- | >>> view one (Dual 7) --- 7 --- --- >>> set one 9 (Dual 7) --- Dual {getDual = 9} -instance HasOne (Dual a) where - type OneItem (Dual a) = a - - setOne _ = Dual - --- | >>> view one (Down 7) --- 7 --- --- >>> set one 9 (Down 7) --- Down 9 -instance HasOne (Down a) where - type OneItem (Down a) = a - - setOne _ = Down - --- | >>> view one (Sum 7) --- 7 --- --- >>> set one 9 (Sum 7) --- Sum {getSum = 9} -instance HasOne (Sum a) where - type OneItem (Sum a) = a - - setOne _ = Sum - --- | >>> view one (Product 7) --- 7 --- --- >>> set one 9 (Product 7) --- Product {getProduct = 9} -instance HasOne (Product a) where - type OneItem (Product a) = a - - setOne _ = Product - --- | >>> view one (Min 7) --- 7 --- --- >>> set one 9 (Min 7) --- Min {getMin = 9} -instance HasOne (Min a) where - type OneItem (Min a) = a - - setOne _ = Min - --- | >>> view one (Max 7) --- 7 --- --- >>> set one 9 (Max 7) --- Max {getMax = 9} -instance HasOne (Max a) where - type OneItem (Max a) = a - - setOne _ = Max - --- | >>> view one (Par1 7) --- 7 --- --- >>> set one 9 (Par1 7) --- Par1 {unPar1 = 9} -instance HasOne (Par1 a) where - type OneItem (Par1 a) = a - - setOne _ = Par1 - --- | >>> view one (MkSolo 7) --- 7 --- --- >>> set one 9 (MkSolo 7) --- MkSolo 9 -instance HasOne (Solo a) where - type OneItem (Solo a) = a - - setOne _ = MkSolo diff --git a/src/Control/One/HasOneItem.hs b/src/Control/One/HasOneItem.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/HasOneItem.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Control.One.HasOneItem where + +import Control.Applicative (Const (..)) +import Control.Lens (Lens', lens, view) +import Control.One.GetterOneItem (GetterOneItem (GetterOneItemElement, getOneItem)) +import Data.Functor.Identity (Identity (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Ord (Down (..)) +import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) +import Data.Tuple (Solo (..)) +import GHC.Generics (Par1 (..)) + +-- $setup +-- >>> import Control.Lens (set) + +class (GetterOneItem x) => HasOneItem x where + type HasOneItemElement x + + setOneItem :: x -> HasOneItemElement x -> x + + oneItem :: Lens' x (HasOneItemElement x) + default oneItem :: (GetterOneItemElement x ~ HasOneItemElement x) => Lens' x (HasOneItemElement x) + oneItem = lens (view getOneItem) setOneItem + +-- | >>> view oneItem (1 :| [2, 3]) +-- 1 +-- +-- >>> set oneItem 9 (1 :| [2, 3]) +-- 9 :| [2,3] +instance HasOneItem (NonEmpty a) where + type HasOneItemElement (NonEmpty a) = a + + setOneItem (_ :| xs) a = a :| xs + +-- | >>> view oneItem ("hello", 42 :: Int) +-- 42 +-- +-- >>> set oneItem 9 ("hello", 42 :: Int) +-- ("hello",9) +instance HasOneItem (x, a) where + type HasOneItemElement (x, a) = a + + setOneItem (x, _) a = (x, a) + +-- | >>> view oneItem (Identity 7) +-- 7 +-- +-- >>> set oneItem 9 (Identity 7) +-- Identity 9 +instance HasOneItem (Identity a) where + type HasOneItemElement (Identity a) = a + + setOneItem _ = Identity + +-- | >>> view oneItem (Const 7 :: Const Int String) +-- 7 +-- +-- >>> set oneItem 9 (Const 7 :: Const Int String) +-- Const 9 +instance HasOneItem (Const a b) where + type HasOneItemElement (Const a b) = a + + setOneItem _ = Const + +-- | >>> view oneItem (First 7) +-- 7 +-- +-- >>> set oneItem 9 (First 7) +-- First {getFirst = 9} +instance HasOneItem (First a) where + type HasOneItemElement (First a) = a + + setOneItem _ = First + +-- | >>> view oneItem (Last 7) +-- 7 +-- +-- >>> set oneItem 9 (Last 7) +-- Last {getLast = 9} +instance HasOneItem (Last a) where + type HasOneItemElement (Last a) = a + + setOneItem _ = Last + +-- | >>> view oneItem (WrapMonoid "hello") +-- "hello" +-- +-- >>> set oneItem "world" (WrapMonoid "hello") +-- WrapMonoid {unwrapMonoid = "world"} +instance HasOneItem (WrappedMonoid a) where + type HasOneItemElement (WrappedMonoid a) = a + + setOneItem _ = WrapMonoid + +-- | >>> view oneItem (Dual 7) +-- 7 +-- +-- >>> set oneItem 9 (Dual 7) +-- Dual {getDual = 9} +instance HasOneItem (Dual a) where + type HasOneItemElement (Dual a) = a + + setOneItem _ = Dual + +-- | >>> view oneItem (Down 7) +-- 7 +-- +-- >>> set oneItem 9 (Down 7) +-- Down 9 +instance HasOneItem (Down a) where + type HasOneItemElement (Down a) = a + + setOneItem _ = Down + +-- | >>> view oneItem (Sum 7) +-- 7 +-- +-- >>> set oneItem 9 (Sum 7) +-- Sum {getSum = 9} +instance HasOneItem (Sum a) where + type HasOneItemElement (Sum a) = a + + setOneItem _ = Sum + +-- | >>> view oneItem (Product 7) +-- 7 +-- +-- >>> set oneItem 9 (Product 7) +-- Product {getProduct = 9} +instance HasOneItem (Product a) where + type HasOneItemElement (Product a) = a + + setOneItem _ = Product + +-- | >>> view oneItem (Min 7) +-- 7 +-- +-- >>> set oneItem 9 (Min 7) +-- Min {getMin = 9} +instance HasOneItem (Min a) where + type HasOneItemElement (Min a) = a + + setOneItem _ = Min + +-- | >>> view oneItem (Max 7) +-- 7 +-- +-- >>> set oneItem 9 (Max 7) +-- Max {getMax = 9} +instance HasOneItem (Max a) where + type HasOneItemElement (Max a) = a + + setOneItem _ = Max + +-- | >>> view oneItem (Par1 7) +-- 7 +-- +-- >>> set oneItem 9 (Par1 7) +-- Par1 {unPar1 = 9} +instance HasOneItem (Par1 a) where + type HasOneItemElement (Par1 a) = a + + setOneItem _ = Par1 + +-- | >>> view oneItem (MkSolo 7) +-- 7 +-- +-- >>> set oneItem 9 (MkSolo 7) +-- MkSolo 9 +instance HasOneItem (Solo a) where + type HasOneItemElement (Solo a) = a + + setOneItem _ = MkSolo diff --git a/src/Control/One/One.hs b/src/Control/One/One.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/One.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Control.One.One + ( -- * One data type + One (..), + One', + one', + rest', + + -- * Type classes + + -- ** GetterOne + GetterOne (..), + + -- ** HasOne + HasOne (..), + + -- ** ReviewOne + ReviewOne (..), + + -- ** AsOne + AsOne (..), + + -- * Optics + + -- ** Identity + identity, + + -- ** NonEmpty + nonEmpty, + + -- ** List + list, + + -- ** Text + text, + lazyText, + shortText, + + -- ** Newtypes + first', + last', + dual, + down, + sum', + product', + min', + max', + wrappedMonoid, + par1, + solo, + const', + + -- ** Tuple + tuple, + ) +where + +import Control.Applicative (Const (..)) +import Control.Lens (Getter, Iso, Lens, Lens', Prism', Review, iso, lens, prism', review, to, unto, view) +import Control.One.AsOneItem (AsOneItem (AsOneItemElement, matchOneItem)) +import Control.One.GetterOneItem (GetterOneItem (GetterOneItemElement, getOneItem)) +import Control.One.HasOneItem (HasOneItem (HasOneItemElement, setOneItem)) +import Control.One.ReviewOneItem (ReviewOneItem (ReviewOneItemElement, reviewOneItem)) +import Data.Biapplicative (Biapplicative (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor.Apply (Biapply (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..), showsBinaryWith) +import Data.Functor.Identity (Identity (Identity)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Ord (Down (..)) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..)) +import Data.Semigroup.Bifoldable (Bifoldable1 (..)) +import Data.Semigroup.Bitraversable (Bitraversable1 (..)) +import Data.Semigroup.Foldable (Foldable1 (..)) +import Data.Semigroup.Traversable (Traversable1 (..)) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Short as ShortText +import Data.Tuple (Solo (..)) +import GHC.Generics (Generic, Par1 (..)) + +-- $setup +-- >>> import Control.Lens (preview, review, set, view) +-- >>> import Control.One.HasOneItem (oneItem) +-- >>> import Control.One.AsOneItem (_OneItem) +-- >>> import Data.Bifunctor (bimap) +-- >>> import Data.Biapplicative (bipure, (<<*>>)) +-- >>> import Data.Bifunctor.Apply ((<<.>>)) +-- >>> import Data.Bifoldable (bifoldMap) +-- >>> import Data.Bitraversable (bitraverse) +-- >>> import Data.Semigroup.Bifoldable (bifoldMap1) +-- >>> import Data.Semigroup.Bitraversable (bitraverse1) +-- >>> import Data.Semigroup.Foldable (foldMap1) +-- >>> import Data.Semigroup.Traversable (traverse1) +-- >>> import Data.Functor.Classes (liftEq, liftCompare, liftShowsPrec, liftEq2, liftCompare2, liftShowsPrec2) +-- >>> import Data.Functor.Identity (Identity(..)) +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> import qualified Data.Text as Text +-- >>> import qualified Data.Text.Lazy as LazyText +-- >>> import qualified Data.Text.Short as ShortText + +data One f a t = One a (f t) + deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) + +-- | >>> :t (One 7 [8, 9] :: One' [] Int) +-- (One 7 [8, 9] :: One' [] Int) :: One' [] Int +type One' f x = One f x x + +-- | >>> view one' (One 7 [8, 9]) +-- 7 +-- +-- >>> set one' 99 (One 7 [8, 9]) +-- One 99 [8,9] +one' :: Lens (One f a t) (One f a' t) a a' +one' f (One a t) = + (`One` t) <$> f a + +-- | >>> view rest' (One 7 [8, 9]) +-- [8,9] +-- +-- >>> set rest' [10, 11] (One 7 [8, 9]) +-- One 7 [10,11] +rest' :: Lens (One f a t) (One f' a t') (f t) (f' t') +rest' f (One a t) = + One a <$> f t + +-- | >>> liftEq (==) (One 1 [2, 3]) (One 1 [2, 3]) +-- True +-- +-- >>> liftEq (==) (One 1 [2]) (One 1 [3]) +-- False +instance (Eq1 f, Eq a) => Eq1 (One f a) where + liftEq eq (One a1 fa1) (One a2 fa2) = a1 == a2 && liftEq eq fa1 fa2 + +-- | >>> liftEq2 (==) (==) (One 1 [2]) (One 1 [2]) +-- True +-- +-- >>> liftEq2 (==) (==) (One 1 [2]) (One 9 [2]) +-- False +instance (Eq1 f) => Eq2 (One f) where + liftEq2 eqa eqa' (One a1 fa1) (One a2 fa2) = eqa a1 a2 && liftEq eqa' fa1 fa2 + +-- | >>> liftCompare compare (One 1 [2]) (One 1 [3]) +-- LT +-- +-- >>> liftCompare compare (One 1 [2]) (One 1 [2]) +-- EQ +instance (Ord1 f, Ord a) => Ord1 (One f a) where + liftCompare cmp (One a1 fa1) (One a2 fa2) = compare a1 a2 <> liftCompare cmp fa1 fa2 + +-- | >>> liftCompare2 compare compare (One 1 [2]) (One 1 [3]) +-- LT +instance (Ord1 f) => Ord2 (One f) where + liftCompare2 cmpa cmpa' (One a1 fa1) (One a2 fa2) = cmpa a1 a2 <> liftCompare cmpa' fa1 fa2 + +-- | >>> liftShowsPrec showsPrec showList 0 (One 1 [2, 3]) "" +-- "One 1 [2,3]" +instance (Show1 f, Show a) => Show1 (One f a) where + liftShowsPrec sp sl d (One a fa) = + showsBinaryWith showsPrec (liftShowsPrec sp sl) "One" d a fa + +-- | >>> liftShowsPrec2 showsPrec showList showsPrec showList 0 (One 1 [2, 3]) "" +-- "One 1 [2,3]" +instance (Show1 f) => Show2 (One f) where + liftShowsPrec2 spa _ spb slb d (One a fa) = + showsBinaryWith spa (liftShowsPrec spb slb) "One" d a fa + +-- | >>> bimap (+1) (*2) (One 3 [4, 5]) +-- One 4 [8,10] +instance (Functor f) => Bifunctor (One f) where + bimap g h (One a ft) = One (g a) (fmap h ft) + +-- | >>> One (+1) [(*2), (*3)] <<.>> One 10 [4, 5] +-- One 11 [8,10,12,15] +instance (Apply f) => Biapply (One f) where + One g ft <<.>> One a fu = One (g a) (ft <.> fu) + +-- | >>> bipure 'a' True :: One [] Char Bool +-- One 'a' [True] +-- +-- >>> One (+1) [(*2)] <<*>> One 10 [4, 5] +-- One 11 [8,10] +instance (Applicative f) => Biapplicative (One f) where + bipure a t = One a (pure t) + One g ft <<*>> One a fu = One (g a) (ft <*> fu) + +-- | >>> bifoldMap show show (One 1 [2, 3]) +-- "123" +instance (Foldable f) => Bifoldable (One f) where + bifoldMap g h (One a ft) = g a <> foldMap h ft + +-- | >>> bitraverse Just Just (One 1 [2, 3]) +-- Just (One 1 [2,3]) +instance (Traversable f) => Bitraversable (One f) where + bitraverse g h (One a ft) = One <$> g a <*> traverse h ft + +-- | >>> bifoldMap1 show show (One 1 [2, 3]) +-- "123" +-- +-- >>> bifoldMap1 show show (One 1 ([] :: [Int])) +-- "1" +instance (Foldable f) => Bifoldable1 (One f) where + bifoldMap1 g h (One a ft) = + case foldMap (Just . h) ft of + Nothing -> g a + Just m -> g a <> m + +-- | >>> bitraverse1 Identity Identity (One 1 (2 :| [3])) +-- Identity (One 1 (2 :| [3])) +instance (Traversable1 f) => Bitraversable1 (One f) where + bitraverse1 g h (One a ft) = One <$> g a <.> traverse1 h ft + +-- | >>> foldMap1 show (One 'x' (1 :| [2, 3])) +-- "123" +instance (Foldable1 f) => Foldable1 (One f a) where + foldMap1 h (One _ ft) = foldMap1 h ft + +-- | >>> traverse1 Identity (One 'x' (1 :| [2, 3])) +-- Identity (One 'x' (1 :| [2,3])) +instance (Traversable1 f) => Traversable1 (One f a) where + traverse1 h (One a ft) = One a <$> traverse1 h ft + +class GetterOne x f a t | x -> f a t where + getOne :: Getter x (One f a t) + +class (GetterOne x f a t) => HasOne x f a t | x -> f a t where + setOne :: x -> One f a t -> x + + one :: Lens' x (One f a t) + default one :: Lens' x (One f a t) + one = lens (view getOne) setOne + + rest :: Lens' x (f t) + rest = one . rest' + +class ReviewOne x f a t | x -> f a t where + reviewOne :: Review x (One f a t) + +class (ReviewOne x f a t) => AsOne x f a t | x -> f a t where + matchOne :: x -> Maybe (One f a t) + + _One :: Prism' x (One f a t) + default _One :: Prism' x (One f a t) + _One = prism' (review reviewOne) matchOne + +-- | >>> view getOne (One 7 [8, 9]) :: One [] Int Int +-- One 7 [8,9] +instance GetterOne (One f a t) f a t where + getOne = to id + +-- | >>> view one (One 7 [8, 9]) :: One [] Int Int +-- One 7 [8,9] +-- +-- >>> set one (One 9 [10]) (One 7 [8, 9]) +-- One 9 [10] +instance HasOne (One f a t) f a t where + setOne _ x = x + rest = rest' + +-- | >>> review reviewOne (One 7 [8]) :: One [] Int Int +-- One 7 [8] +instance ReviewOne (One f a t) f a t where + reviewOne = unto id + +-- | >>> preview _One (One 7 [8]) :: Maybe (One [] Int Int) +-- Just (One 7 [8]) +-- +-- >>> review _One (One 7 [8]) :: One [] Int Int +-- One 7 [8] +instance AsOne (One f a t) f a t where + matchOne = Just + +-- GetterOneItem / HasOneItem / ReviewOneItem / AsOneItem instances + +-- | >>> view getOneItem (One 7 [8, 9]) +-- 7 +instance GetterOneItem (One f a t) where + type GetterOneItemElement (One f a t) = a + + getOneItem = to (\(One a _) -> a) + +-- | >>> view oneItem (One 7 [8, 9]) +-- 7 +-- +-- >>> set oneItem 9 (One 7 [8, 9]) +-- One 9 [8,9] +instance HasOneItem (One f a t) where + type HasOneItemElement (One f a t) = a + + setOneItem (One _ fa) a = One a fa + +-- | >>> review reviewOneItem 7 :: One [] Int Int +-- One 7 [] +instance (Monoid (f t)) => ReviewOneItem (One f a t) where + type ReviewOneItemElement (One f a t) = a + + reviewOneItem = + unto + (`One` mempty) + +-- | >>> preview _OneItem (One 7 ([] :: [Int])) +-- Just 7 +-- +-- >>> preview _OneItem (One 7 [8]) +-- Nothing +-- +-- >>> review _OneItem 7 :: One [] Int Int +-- One 7 [] +instance (Eq (f t), Monoid (f t)) => AsOneItem (One f a t) where + type AsOneItemElement (One f a t) = a + + matchOneItem (One a fa) = + if fa == mempty then Just a else Nothing + +-- | >>> view identity (Identity 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review identity (One 7 Proxy) :: Identity Int +-- Identity 7 +identity :: Iso (Identity a) (Identity a') (One Proxy a t) (One Proxy a' t) +identity = + iso + (\(Identity h) -> One h Proxy) + (\(One h Proxy) -> Identity h) + +-- | >>> view getOne (Identity 7) :: One Proxy Int () +-- One 7 Proxy +instance GetterOne (Identity a) Proxy a () where + getOne = identity + +-- | >>> view one (Identity 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> set one (One 9 Proxy) (Identity 7) +-- Identity 9 +instance HasOne (Identity a) Proxy a () where + setOne _ (One a _) = Identity a + one = identity + +-- | >>> review reviewOne (One 7 Proxy) :: Identity Int +-- Identity 7 +instance ReviewOne (Identity a) Proxy a () where + reviewOne = identity + +-- | >>> preview _One (Identity 7) :: Maybe (One Proxy Int ()) +-- Just (One 7 Proxy) +-- +-- >>> review _One (One 7 Proxy) :: Identity Int +-- Identity 7 +instance AsOne (Identity a) Proxy a () where + matchOne (Identity a) = Just (One a Proxy) + _One = identity + +-- | >>> view nonEmpty (1 :| [2, 3]) +-- One 1 [2,3] +-- +-- >>> review nonEmpty (One 1 [2, 3]) +-- 1 :| [2,3] +nonEmpty :: Iso (NonEmpty a) (NonEmpty b) (One [] a a) (One [] b b) +nonEmpty = + iso + (\(h :| t) -> One h t) + (\(One h t) -> h :| t) + +-- | >>> view getOne (1 :| [2, 3]) :: One [] Int Int +-- One 1 [2,3] +instance GetterOne (NonEmpty a) [] a a where + getOne = nonEmpty + +-- | >>> view one (1 :| [2, 3]) :: One [] Int Int +-- One 1 [2,3] +-- +-- >>> set one (One 9 [10]) (1 :| [2, 3]) +-- 9 :| [10] +instance HasOne (NonEmpty a) [] a a where + setOne _ (One a t) = a :| t + one = nonEmpty + +-- | >>> review reviewOne (One 7 [8, 9]) :: NonEmpty Int +-- 7 :| [8,9] +instance ReviewOne (NonEmpty a) [] a a where + reviewOne = nonEmpty + +-- | >>> preview _One (1 :| [2, 3]) :: Maybe (One [] Int Int) +-- Just (One 1 [2,3]) +-- +-- >>> review _One (One 7 [8, 9]) :: NonEmpty Int +-- 7 :| [8,9] +instance AsOne (NonEmpty a) [] a a where + matchOne (h :| t) = Just (One h t) + _One = nonEmpty + +-- | >>> preview list ['a', 'b', 'c'] +-- Just (One 'a' "bc") +-- +-- >>> preview list ([] :: [Int]) +-- Nothing +-- +-- >>> review list (One 'a' "bc") +-- "abc" +list :: Prism' [a] (One [] a a) +list = + prism' + (\(One h t) -> h : t) + ( \case + [] -> Nothing + (h : t) -> Just (One h t) + ) + +-- | >>> review reviewOne (One 'a' "bc") :: [Char] +-- "abc" +instance ReviewOne [a] [] a a where + reviewOne = list + +-- | >>> preview _One "abc" :: Maybe (One [] Char Char) +-- Just (One 'a' "bc") +-- +-- >>> preview _One ([] :: [Int]) :: Maybe (One [] Int Int) +-- Nothing +instance AsOne [a] [] a a where + matchOne [] = Nothing + matchOne (h : t) = Just (One h t) + +-- | >>> preview text (Text.pack "hello") +-- Just (One 'h' (Const "ello")) +-- +-- >>> preview text Text.empty +-- Nothing +-- +-- >>> review text (One 'h' (Const (Text.pack "ello"))) +-- "hello" +text :: Prism' Text.Text (One (Const Text.Text) Char ()) +text = + prism' + (\(One h (Const t)) -> Text.cons h t) + ( \x -> case Text.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + ) + +-- | >>> review reviewOne (One 'h' (Const (Text.pack "i"))) :: Text.Text +-- "hi" +instance ReviewOne Text.Text (Const Text.Text) Char () where + reviewOne = text + +-- | >>> preview _One (Text.pack "hi") :: Maybe (One (Const Text.Text) Char ()) +-- Just (One 'h' (Const "i")) +-- +-- >>> preview _One Text.empty :: Maybe (One (Const Text.Text) Char ()) +-- Nothing +instance AsOne Text.Text (Const Text.Text) Char () where + matchOne x = case Text.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + +-- | >>> preview lazyText (LazyText.pack "hello") +-- Just (One 'h' (Const "ello")) +-- +-- >>> preview lazyText LazyText.empty +-- Nothing +-- +-- >>> review lazyText (One 'h' (Const (LazyText.pack "ello"))) +-- "hello" +lazyText :: Prism' LazyText.Text (One (Const LazyText.Text) Char ()) +lazyText = + prism' + (\(One h (Const t)) -> LazyText.cons h t) + ( \x -> case LazyText.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + ) + +-- | >>> review reviewOne (One 'h' (Const (LazyText.pack "i"))) :: LazyText.Text +-- "hi" +instance ReviewOne LazyText.Text (Const LazyText.Text) Char () where + reviewOne = lazyText + +-- | >>> preview _One (LazyText.pack "hi") :: Maybe (One (Const LazyText.Text) Char ()) +-- Just (One 'h' (Const "i")) +-- +-- >>> preview _One LazyText.empty :: Maybe (One (Const LazyText.Text) Char ()) +-- Nothing +instance AsOne LazyText.Text (Const LazyText.Text) Char () where + matchOne x = case LazyText.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + +-- | >>> preview shortText (ShortText.pack "hello") +-- Just (One 'h' (Const "ello")) +-- +-- >>> preview shortText (ShortText.pack "") +-- Nothing +-- +-- >>> review shortText (One 'h' (Const (ShortText.pack "ello"))) +-- "hello" +shortText :: Prism' ShortText.ShortText (One (Const ShortText.ShortText) Char ()) +shortText = + prism' + (\(One h (Const t)) -> ShortText.cons h t) + ( \x -> case ShortText.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + ) + +-- | >>> review reviewOne (One 'h' (Const (ShortText.pack "i"))) :: ShortText.ShortText +-- "hi" +instance ReviewOne ShortText.ShortText (Const ShortText.ShortText) Char () where + reviewOne = shortText + +-- | >>> preview _One (ShortText.pack "hi") :: Maybe (One (Const ShortText.ShortText) Char ()) +-- Just (One 'h' (Const "i")) +-- +-- >>> preview _One (ShortText.pack "") :: Maybe (One (Const ShortText.ShortText) Char ()) +-- Nothing +instance AsOne ShortText.ShortText (Const ShortText.ShortText) Char () where + matchOne x = case ShortText.uncons x of + Nothing -> Nothing + Just (h, t) -> Just (One h (Const t)) + +-- | >>> view first' (First 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review first' (One 7 Proxy) :: First Int +-- First {getFirst = 7} +first' :: Iso (First a) (First a') (One Proxy a t) (One Proxy a' t) +first' = + iso + (\(First a) -> One a Proxy) + (\(One a Proxy) -> First a) + +instance GetterOne (First a) Proxy a () where + getOne = first' + +instance HasOne (First a) Proxy a () where + setOne _ (One a _) = First a + one = first' + +instance ReviewOne (First a) Proxy a () where + reviewOne = first' + +instance AsOne (First a) Proxy a () where + matchOne (First a) = Just (One a Proxy) + _One = first' + +-- | >>> view last' (Last 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review last' (One 7 Proxy) :: Last Int +-- Last {getLast = 7} +last' :: Iso (Last a) (Last a') (One Proxy a t) (One Proxy a' t) +last' = + iso + (\(Last a) -> One a Proxy) + (\(One a Proxy) -> Last a) + +instance GetterOne (Last a) Proxy a () where + getOne = last' + +instance HasOne (Last a) Proxy a () where + setOne _ (One a _) = Last a + one = last' + +instance ReviewOne (Last a) Proxy a () where + reviewOne = last' + +instance AsOne (Last a) Proxy a () where + matchOne (Last a) = Just (One a Proxy) + _One = last' + +-- | >>> view dual (Dual 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review dual (One 7 Proxy) :: Dual Int +-- Dual {getDual = 7} +dual :: Iso (Dual a) (Dual a') (One Proxy a t) (One Proxy a' t) +dual = + iso + (\(Dual a) -> One a Proxy) + (\(One a Proxy) -> Dual a) + +instance GetterOne (Dual a) Proxy a () where + getOne = dual + +instance HasOne (Dual a) Proxy a () where + setOne _ (One a _) = Dual a + one = dual + +instance ReviewOne (Dual a) Proxy a () where + reviewOne = dual + +instance AsOne (Dual a) Proxy a () where + matchOne (Dual a) = Just (One a Proxy) + _One = dual + +-- | >>> view down (Down 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review down (One 7 Proxy) :: Down Int +-- Down 7 +down :: Iso (Down a) (Down a') (One Proxy a t) (One Proxy a' t) +down = + iso + (\(Down a) -> One a Proxy) + (\(One a Proxy) -> Down a) + +instance GetterOne (Down a) Proxy a () where + getOne = down + +instance HasOne (Down a) Proxy a () where + setOne _ (One a _) = Down a + one = down + +instance ReviewOne (Down a) Proxy a () where + reviewOne = down + +instance AsOne (Down a) Proxy a () where + matchOne (Down a) = Just (One a Proxy) + _One = down + +-- | >>> view sum' (Sum 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review sum' (One 7 Proxy) :: Sum Int +-- Sum {getSum = 7} +sum' :: Iso (Sum a) (Sum a') (One Proxy a t) (One Proxy a' t) +sum' = + iso + (\(Sum a) -> One a Proxy) + (\(One a Proxy) -> Sum a) + +instance GetterOne (Sum a) Proxy a () where + getOne = sum' + +instance HasOne (Sum a) Proxy a () where + setOne _ (One a _) = Sum a + one = sum' + +instance ReviewOne (Sum a) Proxy a () where + reviewOne = sum' + +instance AsOne (Sum a) Proxy a () where + matchOne (Sum a) = Just (One a Proxy) + _One = sum' + +-- | >>> view product' (Product 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review product' (One 7 Proxy) :: Product Int +-- Product {getProduct = 7} +product' :: Iso (Product a) (Product a') (One Proxy a t) (One Proxy a' t) +product' = + iso + (\(Product a) -> One a Proxy) + (\(One a Proxy) -> Product a) + +instance GetterOne (Product a) Proxy a () where + getOne = product' + +instance HasOne (Product a) Proxy a () where + setOne _ (One a _) = Product a + one = product' + +instance ReviewOne (Product a) Proxy a () where + reviewOne = product' + +instance AsOne (Product a) Proxy a () where + matchOne (Product a) = Just (One a Proxy) + _One = product' + +-- | >>> view min' (Min 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review min' (One 7 Proxy) :: Min Int +-- Min {getMin = 7} +min' :: Iso (Min a) (Min a') (One Proxy a t) (One Proxy a' t) +min' = + iso + (\(Min a) -> One a Proxy) + (\(One a Proxy) -> Min a) + +instance GetterOne (Min a) Proxy a () where + getOne = min' + +instance HasOne (Min a) Proxy a () where + setOne _ (One a _) = Min a + one = min' + +instance ReviewOne (Min a) Proxy a () where + reviewOne = min' + +instance AsOne (Min a) Proxy a () where + matchOne (Min a) = Just (One a Proxy) + _One = min' + +-- | >>> view max' (Max 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review max' (One 7 Proxy) :: Max Int +-- Max {getMax = 7} +max' :: Iso (Max a) (Max a') (One Proxy a t) (One Proxy a' t) +max' = + iso + (\(Max a) -> One a Proxy) + (\(One a Proxy) -> Max a) + +instance GetterOne (Max a) Proxy a () where + getOne = max' + +instance HasOne (Max a) Proxy a () where + setOne _ (One a _) = Max a + one = max' + +instance ReviewOne (Max a) Proxy a () where + reviewOne = max' + +instance AsOne (Max a) Proxy a () where + matchOne (Max a) = Just (One a Proxy) + _One = max' + +-- | >>> view wrappedMonoid (WrapMonoid 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review wrappedMonoid (One 7 Proxy) :: WrappedMonoid Int +-- WrapMonoid {unwrapMonoid = 7} +wrappedMonoid :: Iso (WrappedMonoid a) (WrappedMonoid a') (One Proxy a t) (One Proxy a' t) +wrappedMonoid = + iso + (\(WrapMonoid a) -> One a Proxy) + (\(One a Proxy) -> WrapMonoid a) + +instance GetterOne (WrappedMonoid a) Proxy a () where + getOne = wrappedMonoid + +instance HasOne (WrappedMonoid a) Proxy a () where + setOne _ (One a _) = WrapMonoid a + one = wrappedMonoid + +instance ReviewOne (WrappedMonoid a) Proxy a () where + reviewOne = wrappedMonoid + +instance AsOne (WrappedMonoid a) Proxy a () where + matchOne (WrapMonoid a) = Just (One a Proxy) + _One = wrappedMonoid + +-- | >>> view par1 (Par1 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review par1 (One 7 Proxy) :: Par1 Int +-- Par1 {unPar1 = 7} +par1 :: Iso (Par1 a) (Par1 a') (One Proxy a t) (One Proxy a' t) +par1 = + iso + (\(Par1 a) -> One a Proxy) + (\(One a Proxy) -> Par1 a) + +instance GetterOne (Par1 a) Proxy a () where + getOne = par1 + +instance HasOne (Par1 a) Proxy a () where + setOne _ (One a _) = Par1 a + one = par1 + +instance ReviewOne (Par1 a) Proxy a () where + reviewOne = par1 + +instance AsOne (Par1 a) Proxy a () where + matchOne (Par1 a) = Just (One a Proxy) + _One = par1 + +-- | >>> view solo (MkSolo 7) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review solo (One 7 Proxy) :: Solo Int +-- MkSolo 7 +solo :: Iso (Solo a) (Solo a') (One Proxy a t) (One Proxy a' t) +solo = + iso + (\(MkSolo a) -> One a Proxy) + (\(One a Proxy) -> MkSolo a) + +instance GetterOne (Solo a) Proxy a () where + getOne = solo + +instance HasOne (Solo a) Proxy a () where + setOne _ (One a _) = MkSolo a + one = solo + +instance ReviewOne (Solo a) Proxy a () where + reviewOne = solo + +instance AsOne (Solo a) Proxy a () where + matchOne (MkSolo a) = Just (One a Proxy) + _One = solo + +-- | >>> view const' (Const 7 :: Const Int String) :: One Proxy Int () +-- One 7 Proxy +-- +-- >>> review const' (One 7 Proxy) :: Const Int String +-- Const 7 +const' :: Iso (Const a b) (Const a' b) (One Proxy a t) (One Proxy a' t) +const' = + iso + (\(Const a) -> One a Proxy) + (\(One a Proxy) -> Const a) + +instance GetterOne (Const a b) Proxy a () where + getOne = const' + +instance HasOne (Const a b) Proxy a () where + setOne _ (One a _) = Const a + one = const' + +instance ReviewOne (Const a b) Proxy a () where + reviewOne = const' + +instance AsOne (Const a b) Proxy a () where + matchOne (Const a) = Just (One a Proxy) + _One = const' + +-- | >>> view tuple ("hello", 7) :: One (Const String) Int () +-- One 7 (Const "hello") +-- +-- >>> review tuple (One 7 (Const "hello")) :: (String, Int) +-- ("hello",7) +tuple :: Iso (x, a) (x, a') (One (Const x) a t) (One (Const x) a' t) +tuple = + iso + (\(x, a) -> One a (Const x)) + (\(One a (Const x)) -> (x, a)) + +-- | >>> view getOne ("hello", 7) :: One (Const String) Int () +-- One 7 (Const "hello") +instance GetterOne (x, a) (Const x) a () where + getOne = tuple + +-- | >>> view one ("hello", 7) :: One (Const String) Int () +-- One 7 (Const "hello") +-- +-- >>> set one (One 9 (Const "world")) ("hello", 7) +-- ("world",9) +instance HasOne (x, a) (Const x) a () where + setOne _ (One a (Const x)) = (x, a) + one = tuple + +-- | >>> review reviewOne (One 7 (Const "hello")) :: (String, Int) +-- ("hello",7) +instance ReviewOne (x, a) (Const x) a () where + reviewOne = tuple + +-- | >>> preview _One ("hello", 7) :: Maybe (One (Const String) Int ()) +-- Just (One 7 (Const "hello")) +instance AsOne (x, a) (Const x) a () where + matchOne (x, a) = Just (One a (Const x)) + _One = tuple diff --git a/src/Control/One/ReviewOne.hs b/src/Control/One/ReviewOne.hs deleted file mode 100644 --- a/src/Control/One/ReviewOne.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall -Werror #-} - -module Control.One.ReviewOne where - -import Control.Applicative (Const, ZipList) -import Control.Lens (Review, unto, _Just, _Right, _Wrapped) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.ByteString.Short as ShortByteString -import Data.Functor.Identity (Identity) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Hashable (Hashable) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Ord (Down) -import Data.Semigroup (Dual, First, Last, Max, Min, Product, Sum, WrappedMonoid) -import Data.Sequence (Seq) -import qualified Data.Sequence as Sequence -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import Data.Tuple (Solo (..)) -import Data.Word (Word8) -import GHC.Generics (Par1) - --- $setup --- >>> import Control.Lens (review) - -class ReviewOne x where - type ReviewOneItem x - - reviewOne :: Review x (ReviewOneItem x) - --- | >>> review reviewOne 7 :: [Int] --- [7] -instance ReviewOne [a] where - type ReviewOneItem [a] = a - - reviewOne = unto (: []) - --- | >>> review reviewOne 7 :: NonEmpty Int --- 7 :| [] -instance ReviewOne (NonEmpty a) where - type ReviewOneItem (NonEmpty a) = a - - reviewOne = - unto - (:| []) - --- | >>> review reviewOne 7 :: Seq Int --- fromList [7] -instance ReviewOne (Seq a) where - type ReviewOneItem (Seq a) = a - - reviewOne = - unto - Sequence.singleton - --- | >>> review reviewOne 'a' :: Text.Text --- "a" -instance ReviewOne Text.Text where - type ReviewOneItem Text.Text = Char - - reviewOne = - unto - Text.singleton - --- | >>> review reviewOne 'a' :: LazyText.Text --- "a" -instance ReviewOne LazyText.Text where - type ReviewOneItem LazyText.Text = Char - - reviewOne = - unto - LazyText.singleton - --- | >>> review reviewOne 65 :: ByteString.ByteString --- "A" -instance ReviewOne ByteString.ByteString where - type ReviewOneItem ByteString.ByteString = Word8 - - reviewOne = - unto - ByteString.singleton - --- | >>> review reviewOne 65 :: LazyByteString.ByteString --- "A" -instance ReviewOne LazyByteString.ByteString where - type ReviewOneItem LazyByteString.ByteString = Word8 - - reviewOne = - unto - LazyByteString.singleton - --- | >>> review reviewOne 65 :: ShortByteString.ShortByteString --- "A" -instance ReviewOne ShortByteString.ShortByteString where - type ReviewOneItem ShortByteString.ShortByteString = Word8 - - reviewOne = - unto - ShortByteString.singleton - --- | >>> review reviewOne ("key", 7 :: Int) :: Map String Int --- fromList [("key",7)] -instance ReviewOne (Map k v) where - type ReviewOneItem (Map k v) = (k, v) - - reviewOne = - unto - (uncurry Map.singleton) - --- | >>> review reviewOne ("key", 7 :: Int) :: HashMap String Int --- fromList [("key",7)] -instance (Hashable k) => ReviewOne (HashMap k v) where - type ReviewOneItem (HashMap k v) = (k, v) - - reviewOne = - unto - (uncurry HashMap.singleton) - --- | >>> review reviewOne (1, 7 :: Int) :: IntMap Int --- fromList [(1,7)] -instance ReviewOne (IntMap v) where - type ReviewOneItem (IntMap v) = (Int, v) - - reviewOne = - unto - (uncurry IntMap.singleton) - --- | >>> review reviewOne 7 :: Set Int --- fromList [7] -instance ReviewOne (Set a) where - type ReviewOneItem (Set a) = a - - reviewOne = - unto - Set.singleton - --- | >>> review reviewOne 7 :: HashSet Int --- fromList [7] -instance (Hashable a) => ReviewOne (HashSet a) where - type ReviewOneItem (HashSet a) = a - - reviewOne = - unto - HashSet.singleton - --- | >>> review reviewOne 7 :: IntSet --- fromList [7] -instance ReviewOne IntSet where - type ReviewOneItem IntSet = Int - - reviewOne = - unto - IntSet.singleton - --- | >>> review reviewOne 7 :: (String, Int) --- ("",7) -instance (Eq a, Monoid a) => ReviewOne (a, b) where - type ReviewOneItem (a, b) = b - - reviewOne = - unto - (mempty,) - --- | >>> review reviewOne 7 :: Maybe Int --- Just 7 -instance ReviewOne (Maybe a) where - type ReviewOneItem (Maybe a) = a - - reviewOne = - _Just - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Either String Int --- Right 7 -instance ReviewOne (Either a b) where - type ReviewOneItem (Either a b) = b - - reviewOne = - _Right - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Identity Int --- Identity 7 -instance ReviewOne (Identity a) where - type ReviewOneItem (Identity a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Const Int String --- Const 7 -instance ReviewOne (Const a b) where - type ReviewOneItem (Const a b) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: First Int --- First {getFirst = 7} -instance ReviewOne (First a) where - type ReviewOneItem (First a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Last Int --- Last {getLast = 7} -instance ReviewOne (Last a) where - type ReviewOneItem (Last a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: WrappedMonoid Int --- WrapMonoid {unwrapMonoid = 7} -instance ReviewOne (WrappedMonoid a) where - type ReviewOneItem (WrappedMonoid a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Dual Int --- Dual {getDual = 7} -instance ReviewOne (Dual a) where - type ReviewOneItem (Dual a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Down Int --- Down 7 -instance ReviewOne (Down a) where - type ReviewOneItem (Down a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Sum Int --- Sum {getSum = 7} -instance ReviewOne (Sum a) where - type ReviewOneItem (Sum a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Product Int --- Product {getProduct = 7} -instance ReviewOne (Product a) where - type ReviewOneItem (Product a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Min Int --- Min {getMin = 7} -instance ReviewOne (Min a) where - type ReviewOneItem (Min a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Max Int --- Max {getMax = 7} -instance ReviewOne (Max a) where - type ReviewOneItem (Max a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: ZipList Int --- ZipList {getZipList = [7]} -instance ReviewOne (ZipList a) where - type ReviewOneItem (ZipList a) = a - - reviewOne = - _Wrapped . reviewOne - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Par1 Int --- Par1 {unPar1 = 7} -instance ReviewOne (Par1 a) where - type ReviewOneItem (Par1 a) = a - - reviewOne = - _Wrapped - {-# INLINE reviewOne #-} - --- | >>> review reviewOne 7 :: Solo Int --- MkSolo 7 -instance ReviewOne (Solo a) where - type ReviewOneItem (Solo a) = a - - reviewOne = - unto - MkSolo - {-# INLINE reviewOne #-} diff --git a/src/Control/One/ReviewOneItem.hs b/src/Control/One/ReviewOneItem.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/ReviewOneItem.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Control.One.ReviewOneItem where + +import Control.Applicative (Const, ZipList) +import Control.Lens (Review, unto, _Just, _Right, _Wrapped) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.ByteString.Short as ShortByteString +import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord (Down) +import Data.Semigroup (Dual, First, Last, Max, Min, Product, Sum, WrappedMonoid) +import Data.Sequence (Seq) +import qualified Data.Sequence as Sequence +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Short as ShortText +import Data.Tuple (Solo (..)) +import Data.Word (Word8) +import GHC.Generics (Par1) + +-- $setup +-- >>> import Control.Lens (review) + +class ReviewOneItem x where + type ReviewOneItemElement x + + reviewOneItem :: Review x (ReviewOneItemElement x) + +-- | >>> review reviewOneItem 7 :: [Int] +-- [7] +instance ReviewOneItem [a] where + type ReviewOneItemElement [a] = a + + reviewOneItem = unto (: []) + +-- | >>> review reviewOneItem 7 :: NonEmpty Int +-- 7 :| [] +instance ReviewOneItem (NonEmpty a) where + type ReviewOneItemElement (NonEmpty a) = a + + reviewOneItem = + unto + (:| []) + +-- | >>> review reviewOneItem 7 :: Seq Int +-- fromList [7] +instance ReviewOneItem (Seq a) where + type ReviewOneItemElement (Seq a) = a + + reviewOneItem = + unto + Sequence.singleton + +-- | >>> review reviewOneItem 'a' :: Text.Text +-- "a" +instance ReviewOneItem Text.Text where + type ReviewOneItemElement Text.Text = Char + + reviewOneItem = + unto + Text.singleton + +-- | >>> review reviewOneItem 'a' :: LazyText.Text +-- "a" +instance ReviewOneItem LazyText.Text where + type ReviewOneItemElement LazyText.Text = Char + + reviewOneItem = + unto + LazyText.singleton + +-- | >>> review reviewOneItem 'a' :: ShortText.ShortText +-- "a" +instance ReviewOneItem ShortText.ShortText where + type ReviewOneItemElement ShortText.ShortText = Char + + reviewOneItem = + unto + ShortText.singleton + +-- | >>> review reviewOneItem 65 :: ByteString.ByteString +-- "A" +instance ReviewOneItem ByteString.ByteString where + type ReviewOneItemElement ByteString.ByteString = Word8 + + reviewOneItem = + unto + ByteString.singleton + +-- | >>> review reviewOneItem 65 :: LazyByteString.ByteString +-- "A" +instance ReviewOneItem LazyByteString.ByteString where + type ReviewOneItemElement LazyByteString.ByteString = Word8 + + reviewOneItem = + unto + LazyByteString.singleton + +-- | >>> review reviewOneItem 65 :: ShortByteString.ShortByteString +-- "A" +instance ReviewOneItem ShortByteString.ShortByteString where + type ReviewOneItemElement ShortByteString.ShortByteString = Word8 + + reviewOneItem = + unto + ShortByteString.singleton + +-- | >>> review reviewOneItem ("key", 7 :: Int) :: Map String Int +-- fromList [("key",7)] +instance ReviewOneItem (Map k v) where + type ReviewOneItemElement (Map k v) = (k, v) + + reviewOneItem = + unto + (uncurry Map.singleton) + +-- | >>> review reviewOneItem ("key", 7 :: Int) :: HashMap String Int +-- fromList [("key",7)] +instance (Hashable k) => ReviewOneItem (HashMap k v) where + type ReviewOneItemElement (HashMap k v) = (k, v) + + reviewOneItem = + unto + (uncurry HashMap.singleton) + +-- | >>> review reviewOneItem (1, 7 :: Int) :: IntMap Int +-- fromList [(1,7)] +instance ReviewOneItem (IntMap v) where + type ReviewOneItemElement (IntMap v) = (Int, v) + + reviewOneItem = + unto + (uncurry IntMap.singleton) + +-- | >>> review reviewOneItem 7 :: Set Int +-- fromList [7] +instance ReviewOneItem (Set a) where + type ReviewOneItemElement (Set a) = a + + reviewOneItem = + unto + Set.singleton + +-- | >>> review reviewOneItem 7 :: HashSet Int +-- fromList [7] +instance (Hashable a) => ReviewOneItem (HashSet a) where + type ReviewOneItemElement (HashSet a) = a + + reviewOneItem = + unto + HashSet.singleton + +-- | >>> review reviewOneItem 7 :: IntSet +-- fromList [7] +instance ReviewOneItem IntSet where + type ReviewOneItemElement IntSet = Int + + reviewOneItem = + unto + IntSet.singleton + +-- | >>> review reviewOneItem 7 :: (String, Int) +-- ("",7) +instance (Monoid a) => ReviewOneItem (a, b) where + type ReviewOneItemElement (a, b) = b + + reviewOneItem = + unto + (mempty,) + +-- | >>> review reviewOneItem 7 :: Maybe Int +-- Just 7 +instance ReviewOneItem (Maybe a) where + type ReviewOneItemElement (Maybe a) = a + + reviewOneItem = + _Just + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Either String Int +-- Right 7 +instance ReviewOneItem (Either a b) where + type ReviewOneItemElement (Either a b) = b + + reviewOneItem = + _Right + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Identity Int +-- Identity 7 +instance ReviewOneItem (Identity a) where + type ReviewOneItemElement (Identity a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Const Int String +-- Const 7 +instance ReviewOneItem (Const a b) where + type ReviewOneItemElement (Const a b) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: First Int +-- First {getFirst = 7} +instance ReviewOneItem (First a) where + type ReviewOneItemElement (First a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Last Int +-- Last {getLast = 7} +instance ReviewOneItem (Last a) where + type ReviewOneItemElement (Last a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: WrappedMonoid Int +-- WrapMonoid {unwrapMonoid = 7} +instance ReviewOneItem (WrappedMonoid a) where + type ReviewOneItemElement (WrappedMonoid a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Dual Int +-- Dual {getDual = 7} +instance ReviewOneItem (Dual a) where + type ReviewOneItemElement (Dual a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Down Int +-- Down 7 +instance ReviewOneItem (Down a) where + type ReviewOneItemElement (Down a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Sum Int +-- Sum {getSum = 7} +instance ReviewOneItem (Sum a) where + type ReviewOneItemElement (Sum a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Product Int +-- Product {getProduct = 7} +instance ReviewOneItem (Product a) where + type ReviewOneItemElement (Product a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Min Int +-- Min {getMin = 7} +instance ReviewOneItem (Min a) where + type ReviewOneItemElement (Min a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Max Int +-- Max {getMax = 7} +instance ReviewOneItem (Max a) where + type ReviewOneItemElement (Max a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: ZipList Int +-- ZipList {getZipList = [7]} +instance ReviewOneItem (ZipList a) where + type ReviewOneItemElement (ZipList a) = a + + reviewOneItem = + _Wrapped . reviewOneItem + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Par1 Int +-- Par1 {unPar1 = 7} +instance ReviewOneItem (Par1 a) where + type ReviewOneItemElement (Par1 a) = a + + reviewOneItem = + _Wrapped + {-# INLINE reviewOneItem #-} + +-- | >>> review reviewOneItem 7 :: Solo Int +-- MkSolo 7 +instance ReviewOneItem (Solo a) where + type ReviewOneItemElement (Solo a) = a + + reviewOneItem = + unto + MkSolo + {-# INLINE reviewOneItem #-}