diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright 2026 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.0.1 + +* This change log starts diff --git a/one.cabal b/one.cabal new file mode 100644 --- /dev/null +++ b/one.cabal @@ -0,0 +1,52 @@ +cabal-version: 2.4 +name: one +version: 0.0.1 +synopsis: One +description: Data types that have a singleton view +license: BSD-3-Clause +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2026 Tony Morris +category: Data +build-type: Simple +extra-doc-files: changelog.md +homepage: https://gitlab.com/tonymorris/one +bug-reports: https://gitlab.com/tonymorris/one/issues +tested-with: GHC == 9.6.7 + +source-repository head + type: git + location: git@gitlab.com:tonymorris/one.git + +library + exposed-modules: + Control.One + Control.One.AsOne + Control.One.GetterOne + Control.One.HasOne + Control.One.ReviewOne + + build-depends: base >= 4.8 && < 6 + , lens >= 4 && < 6 + , text >= 1.2 && < 3 + , containers >= 0.5 && < 1 + , unordered-containers >= 0.2 && < 1 + , hashable >= 1.2 && < 2 + , bytestring >= 0.10 && < 1 + + hs-source-dirs: src + + default-language: Haskell2010 + + ghc-options: -Wall + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Control/One.hs b/src/Control/One.hs new file mode 100644 --- /dev/null +++ b/src/Control/One.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Type-class abstractions for data types with a singleton view, built on +-- [lens](https://hackage.haskell.org/package/lens). +-- +-- == Overview +-- +-- 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: +-- +-- @ +-- 'GetterOne' 'ReviewOne' +-- | | +-- 'HasOne' 'AsOne' +-- @ +-- +-- === Lens hierarchy (total access) +-- +-- For types that /always/ contain exactly one element: +-- +-- * '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'. +-- +-- === Prism hierarchy (partial access) +-- +-- For types that /might/ contain exactly one element: +-- +-- * 'ReviewOne' — provides @'reviewOne' :: 'Control.Lens.Review' x ('ReviewOneItem' x)@ to +-- construct a singleton value from an element. +-- * 'AsOne' (superclass: 'ReviewOne') — provides @'_One' :: 'Control.Lens.Prism'' x ('AsOneItem' x)@ +-- to both construct and pattern-match singleton values. A default +-- implementation is derived from 'reviewOne' and 'matchOne'. +-- +-- == Usage +-- +-- === Constructing singleton values +-- +-- >>> 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] +-- +-- >>> review reviewOne 7 :: Set Int +-- fromList [7] +-- +-- >>> review _One 7 :: Maybe Int +-- Just 7 +-- +-- === Matching singleton values +-- +-- >>> preview _One [7] +-- Just 7 +-- +-- >>> preview _One [1, 2] +-- Nothing +-- +-- >>> preview _One (Nothing :: Maybe Int) +-- Nothing +-- +-- === Getting and setting (total types) +-- +-- >>> view one (1 :| [2, 3]) +-- 1 +-- +-- >>> set one 9 (1 :| [2, 3]) +-- 9 :| [2,3] +-- +-- >>> view one (Identity 7) +-- 7 +-- +-- == Instances +-- +-- Instances are provided for a wide range of standard types including: +-- +-- * __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) +-- * __Maybe and Either__: 'Maybe', 'Either' +-- * __Newtypes__: 'Data.Functor.Identity.Identity', 'Data.Functor.Const.Const', +-- 'Data.Semigroup.First', 'Data.Semigroup.Last', 'Data.Semigroup.Min', +-- 'Data.Semigroup.Max', 'Data.Semigroup.Dual', 'Data.Semigroup.Sum', +-- 'Data.Semigroup.Product', 'Data.Semigroup.WrappedMonoid', +-- 'Data.Ord.Down', 'Control.Applicative.ZipList', 'GHC.Generics.Par1', 'Data.Tuple.Solo' +-- * __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'). +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 diff --git a/src/Control/One/AsOne.hs b/src/Control/One/AsOne.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/AsOne.hs @@ -0,0 +1,478 @@ +{-# 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/GetterOne.hs b/src/Control/One/GetterOne.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/GetterOne.hs @@ -0,0 +1,126 @@ +{-# 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/HasOne.hs b/src/Control/One/HasOne.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/HasOne.hs @@ -0,0 +1,178 @@ +{-# 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/ReviewOne.hs b/src/Control/One/ReviewOne.hs new file mode 100644 --- /dev/null +++ b/src/Control/One/ReviewOne.hs @@ -0,0 +1,321 @@ +{-# 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/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} + +module Main where + +import System.Exit (exitWith) +import System.Process (rawSystem) + +main :: IO () +main = + exitWith + =<< rawSystem + "cabal" + [ "repl", + "--with-compiler=doctest", + "--repl-options=-w", + "--repl-options=-Wdefault", + "lib:one" + ]