diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/focus.cabal b/focus.cabal --- a/focus.cabal +++ b/focus.cabal @@ -1,65 +1,102 @@ -name: - focus -version: - 0.1.5.2 +cabal-version: 3.0 +name: focus +version: 1.0.3.2 synopsis: A general abstraction for manipulating elements of container data structures + description: An API for construction of free-form strategies of access and manipulation of elements of arbitrary data structures. It allows to implement efficient composite patterns, e.g., a simultaneous update and lookup of an element, and even more complex things. - . Strategies are meant to be interpreted by the host data structure libraries. Thus they allow to implement all access and modification patterns of a data structure with just a single function, which interprets strategies. - . This library provides pure and monadic interfaces, so it supports both immutable and mutable data structures. -category: - Containers, Data -homepage: - https://github.com/nikita-volkov/focus -bug-reports: - https://github.com/nikita-volkov/focus/issues -author: - Nikita Volkov -maintainer: - Nikita Volkov -copyright: - (c) 2014, Nikita Volkov -license: - MIT -license-file: - LICENSE -build-type: - Simple -cabal-version: - >=1.10 -tested-with: - GHC==7.6.3, - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.1 - GHC==8.2.1 +category: Containers, Data +homepage: https://github.com/nikita-volkov/focus +bug-reports: https://github.com/nikita-volkov/focus/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2014, Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: - git - location: - git://github.com/nikita-volkov/focus.git + type: git + location: git://github.com/nikita-volkov/focus.git +common language-settings + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + DuplicateRecordFields + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NumericUnderscores + OverloadedLabels + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + default-language: Haskell2010 + library - hs-source-dirs: - library - exposed-modules: - Focus + import: language-settings + hs-source-dirs: library + exposed-modules: Focus + other-modules: Focus.Prelude build-depends: - base >= 4.6 && < 5 - default-extensions: - DeriveFunctor, NoImplicitPrelude, TupleSections - default-language: - Haskell2010 + , base >=4.11 && <5 + , transformers >=0.5 && <0.7 + +test-suite test + import: language-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , focus + , rerebase <2 + , tasty >=0.12 && <2 + , tasty-hunit >=0.9 && <0.11 diff --git a/library/Focus.hs b/library/Focus.hs --- a/library/Focus.hs +++ b/library/Focus.hs @@ -1,115 +1,390 @@ module Focus where -import Prelude hiding (adjust, update, alter, insert, delete, lookup) -import Control.Monad - +import Focus.Prelude hiding (delete, insert, lookup) -- | --- A general modification function for some match. --- By processing a 'Maybe' value it produces some value to emit and --- a 'Decision' to perform on the match. --- --- The interpretation of this function is up to the context APIs. -type Strategy a r = Maybe a -> (r, Decision a) +-- Abstraction over the modification of an element of a datastructure. +-- +-- It is composable using the standard typeclasses, e.g.: +-- +-- >lookupAndDelete :: Monad m => Focus a m (Maybe a) +-- >lookupAndDelete = lookup <* delete +data Focus element m result = Focus (m (result, Change element)) (element -> m (result, Change element)) --- | --- A monadic version of 'Strategy'. -type StrategyM m a r = Maybe a -> m (r, Decision a) +deriving instance (Functor m) => Functor (Focus element m) +instance (Monad m) => Applicative (Focus element m) where + pure a = Focus (pure (a, Leave)) (const (pure (a, Leave))) + (<*>) = ap + +instance (Monad m) => Monad (Focus element m) where + return = pure + (>>=) (Focus lAbsent lPresent) rk = + Focus absent present + where + absent = + do + (lr, lChange) <- lAbsent + let Focus rAbsent rPresent = rk lr + case lChange of + Leave -> rAbsent + Remove -> rAbsent & fmap (fmap (mappend lChange)) + Set newElement -> rPresent newElement & fmap (fmap (mappend lChange)) + present element = + do + (lr, lChange) <- lPresent element + let Focus rAbsent rPresent = rk lr + case lChange of + Leave -> rPresent element + Remove -> rAbsent & fmap (fmap (mappend lChange)) + Set newElement -> rPresent newElement & fmap (fmap (mappend lChange)) + +instance MonadTrans (Focus element) where + lift m = Focus (fmap (,Leave) m) (const (fmap (,Leave) m)) + -- | -- What to do with the focused value. --- +-- -- The interpretation of the commands is up to the context APIs. -data Decision a = - Keep | - Remove | - Replace a - deriving (Functor) +data Change a + = -- | Produce no changes + Leave + | -- | Delete it + Remove + | -- | Set its value to the provided one + Set a + deriving (Functor, Eq, Ord, Show) +instance Semigroup (Change a) where + (<>) l r = + case r of + Leave -> l + _ -> r --- * Constructors for common pure patterns -------------------------- +instance Monoid (Change a) where + mempty = Leave +-- * Pure functions + +-- ** Reading functions + -- | -- Reproduces the behaviour of --- @Data.Map.@. -{-# INLINE adjust #-} -adjust :: (a -> a) -> Strategy a () -adjust f = maybe ((), Keep) (\a -> ((), Replace (f a))) +-- @Data.Map.@. +{-# INLINE member #-} +member :: (Monad m) => Focus a m Bool +member = fmap (maybe False (const True)) lookup -- | -- Reproduces the behaviour of --- @Data.Map.@. -{-# INLINE update #-} -update :: (a -> Maybe a) -> Strategy a () -update f = maybe ((), Keep) (\a -> ((), maybe Remove Replace (f a))) +-- @Data.Map.@. +{-# INLINE [1] lookup #-} +lookup :: (Monad m) => Focus a m (Maybe a) +lookup = cases (Nothing, Leave) (\a -> (Just a, Leave)) -- | -- Reproduces the behaviour of --- @Data.Map.@. -{-# INLINE alter #-} -alter :: (Maybe a -> Maybe a) -> Strategy a () -alter f = ((),) . maybe Remove Replace . f +-- @Data.Map.@ +-- with a better name. +{-# INLINE [1] lookupWithDefault #-} +lookupWithDefault :: (Monad m) => a -> Focus a m a +lookupWithDefault a = cases (a, Leave) (\a -> (a, Leave)) +-- ** Modifying functions + -- | -- Reproduces the behaviour of --- @Data.Map.@. +-- @Data.Map.@. +{-# INLINE [1] delete #-} +delete :: (Monad m) => Focus a m () +delete = unitCases Leave (const Remove) + +-- | +-- Lookup an element and delete it if it exists. +-- +-- Same as @'lookup' <* 'delete'@. +{-# RULES +"lookup <* delete" [~1] lookup <* delete = lookupAndDelete + #-} + +{-# INLINE lookupAndDelete #-} +lookupAndDelete :: (Monad m) => Focus a m (Maybe a) +lookupAndDelete = cases (Nothing, Leave) (\element -> (Just element, Remove)) + +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE insert #-} -insert :: a -> Strategy a () -insert a = const ((), Replace a) +insert :: (Monad m) => a -> Focus a m () +insert a = unitCases (Set a) (const (Set a)) -- | -- Reproduces the behaviour of --- @Data.Map.@. -{-# INLINE delete #-} -delete :: Strategy a () -delete = const ((), Remove) +-- @Data.Map.@ +-- with a better name. +{-# INLINE insertOrMerge #-} +insertOrMerge :: (Monad m) => (a -> a -> a) -> a -> Focus a m () +insertOrMerge merge value = unitCases (Set value) (Set . merge value) -- | -- Reproduces the behaviour of --- @Data.Map.@. -{-# INLINE lookup #-} -lookup :: Strategy a (Maybe a) -lookup r = (r, Keep) +-- @Data.Map.@. +{-# INLINE alter #-} +alter :: (Monad m) => (Maybe a -> Maybe a) -> Focus a m () +alter fn = unitCases (maybe Leave Set (fn Nothing)) (maybe Remove Set . fn . Just) +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. +{-# INLINE adjust #-} +adjust :: (Monad m) => (a -> a) -> Focus a m () +adjust fn = unitCases Leave (Set . fn) --- * Constructors for monadic patterns -------------------------- +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. +{-# INLINE update #-} +update :: (Monad m) => (a -> Maybe a) -> Focus a m () +update fn = unitCases Leave (maybe Remove Set . fn) -- | +-- Same as all of the following expressions: +-- +-- @\f g -> fmap (fmap f) lookup <* adjust g@ +-- @\f g -> liftStateFn (f &&& g)@ +-- @\f g -> liftStateFn ((,) <$> f <*> g)@ +accessAndAdjust :: (Monad m) => (s -> a) -> (s -> s) -> Focus s m (Maybe a) +accessAndAdjust f g = + liftStateFn (f &&& g) + +-- | +-- Lift a pure state monad. +liftState :: (Monad m) => State s a -> Focus s m (Maybe a) +liftState (StateT fn) = + liftStateFn (runIdentity . fn) + +-- | +-- Lift a pure state-monad-like function. +liftStateFn :: (Monad m) => (s -> (a, s)) -> Focus s m (Maybe a) +liftStateFn fn = + Focus + (return (Nothing, Leave)) + (\s -> case fn s of (a, s) -> return (Just a, Set s)) + +-- ** Construction utils + +-- | +-- Lift pure functions which handle the cases of presence and absence of the element. +{-# INLINE cases #-} +cases :: (Monad m) => (b, Change a) -> (a -> (b, Change a)) -> Focus a m b +cases sendNone sendSome = Focus (return sendNone) (return . sendSome) + +-- | +-- Lift pure functions which handle the cases of presence and absence of the element and produce no result. +{-# INLINE unitCases #-} +unitCases :: (Monad m) => Change a -> (a -> Change a) -> Focus a m () +unitCases sendNone sendSome = cases ((), sendNone) (\a -> ((), sendSome a)) + +-- * Monadic functions + +-- ** Reading functions + +-- | +-- A monadic version of 'lookupWithDefault'. +{-# INLINE [1] lookupWithDefaultM #-} +lookupWithDefaultM :: (Monad m) => m a -> Focus a m a +lookupWithDefaultM aM = casesM (liftM2 (,) aM (return Leave)) (\a -> return (a, Leave)) + +-- ** Modifying functions + +-- | +-- A monadic version of 'insert'. +{-# INLINE insertM #-} +insertM :: (Monad m) => m a -> Focus a m () +insertM aM = unitCasesM (fmap Set aM) (const (fmap Set aM)) + +-- | +-- A monadic version of 'insertOrMerge'. +{-# INLINE insertOrMergeM #-} +insertOrMergeM :: (Monad m) => (a -> a -> m a) -> m a -> Focus a m () +insertOrMergeM merge aM = unitCasesM (fmap Set aM) (\a' -> aM >>= \a -> fmap Set (merge a a')) + +-- | +-- A monadic version of 'alter'. +{-# INLINE alterM #-} +alterM :: (Monad m) => (Maybe a -> m (Maybe a)) -> Focus a m () +alterM fn = unitCasesM (fmap (maybe Leave Set) (fn Nothing)) (fmap (maybe Remove Set) . fn . Just) + +-- | -- A monadic version of 'adjust'. {-# INLINE adjustM #-} -adjustM :: (Monad m) => (a -> m a) -> StrategyM m a () -adjustM f = maybe (return ((), Keep)) (liftM (((),) . Replace) . f) +adjustM :: (Monad m) => (a -> m a) -> Focus a m () +adjustM fn = updateM (fmap Just . fn) -- | -- A monadic version of 'update'. {-# INLINE updateM #-} -updateM :: (Monad m) => (a -> m (Maybe a)) -> StrategyM m a () -updateM f = maybe (return ((), Keep)) (liftM (((),) . maybe Remove Replace) . f) +updateM :: (Monad m) => (a -> m (Maybe a)) -> Focus a m () +updateM fn = unitCasesM (return Leave) (fmap (maybe Remove Set) . fn) +-- ** Construction utils + -- | --- A monadic version of 'alter'. -{-# INLINE alterM #-} -alterM :: (Monad m) => (Maybe a -> m (Maybe a)) -> StrategyM m a () -alterM f = liftM (((),) . maybe Remove Replace) . f +-- Lift monadic functions which handle the cases of presence and absence of the element. +{-# INLINE casesM #-} +casesM :: m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b +casesM sendNone sendSome = Focus sendNone sendSome -- | --- A monadic version of 'insert'. -{-# INLINE insertM #-} -insertM :: (Monad m) => a -> StrategyM m a () -insertM = fmap return . insert +-- Lift monadic functions which handle the cases of presence and absence of the element and produce no result. +{-# INLINE unitCasesM #-} +unitCasesM :: (Monad m) => m (Change a) -> (a -> m (Change a)) -> Focus a m () +unitCasesM sendNone sendSome = Focus (fmap ((),) sendNone) (\a -> fmap ((),) (sendSome a)) +-- * Composition + -- | --- A monadic version of 'delete'. -{-# INLINE deleteM #-} -deleteM :: (Monad m) => StrategyM m a () -deleteM = fmap return delete +-- Map the Focus input. +{-# INLINE mappingInput #-} +mappingInput :: (Monad m) => (a -> b) -> (b -> a) -> Focus a m x -> Focus b m x +mappingInput aToB bToA (Focus consealA revealA) = Focus consealB revealB + where + consealB = do + (x, aChange) <- consealA + return (x, fmap aToB aChange) + revealB b = do + (x, aChange) <- revealA (bToA b) + return (x, fmap aToB aChange) +-- * Change-inspecting functions + -- | --- A monadic version of 'lookup'. -{-# INLINE lookupM #-} -lookupM :: (Monad m) => StrategyM m a (Maybe a) -lookupM = fmap return lookup +-- Extends the output with the input. +{-# INLINE extractingInput #-} +extractingInput :: (Monad m) => Focus a m b -> Focus a m (b, Maybe a) +extractingInput (Focus absent present) = + Focus newAbsent newPresent + where + newAbsent = do + (b, change) <- absent + return ((b, Nothing), change) + newPresent element = do + (b, change) <- present element + return ((b, Just element), change) +-- | +-- Extends the output with the change performed. +{-# INLINE extractingChange #-} +extractingChange :: (Monad m) => Focus a m b -> Focus a m (b, Change a) +extractingChange (Focus absent present) = + Focus newAbsent newPresent + where + newAbsent = do + (b, change) <- absent + return ((b, change), change) + newPresent element = do + (b, change) <- present element + return ((b, change), change) +-- | +-- Extends the output with a projection on the change that was performed. +{-# INLINE projectingChange #-} +projectingChange :: (Monad m) => (Change a -> c) -> Focus a m b -> Focus a m (b, c) +projectingChange fn (Focus absent present) = + Focus newAbsent newPresent + where + newAbsent = do + (b, change) <- absent + return ((b, fn change), change) + newPresent element = do + (b, change) <- present element + return ((b, fn change), change) + +-- | +-- Extends the output with a flag, +-- signaling whether a change, which is not 'Leave', has been introduced. +{-# INLINE testingIfModifies #-} +testingIfModifies :: (Monad m) => Focus a m b -> Focus a m (b, Bool) +testingIfModifies = + projectingChange $ \case + Leave -> False + _ -> True + +-- | +-- Extends the output with a flag, +-- signaling whether the 'Remove' change has been introduced. +{-# INLINE testingIfRemoves #-} +testingIfRemoves :: (Monad m) => Focus a m b -> Focus a m (b, Bool) +testingIfRemoves = + projectingChange $ \case + Remove -> True + _ -> False + +-- | +-- Extends the output with a flag, +-- signaling whether an item will be inserted. +-- That is, it didn't exist before and a 'Set' change is introduced. +{-# INLINE testingIfInserts #-} +testingIfInserts :: (Monad m) => Focus a m b -> Focus a m (b, Bool) +testingIfInserts (Focus absent present) = + Focus newAbsent newPresent + where + newAbsent = do + (output, change) <- absent + let testResult = case change of + Set _ -> True + _ -> False + in return ((output, testResult), change) + newPresent element = do + (output, change) <- present element + return ((output, False), change) + +-- | +-- Extend the output with a flag, signaling how the size will be affected by the change. +{-# INLINE testingSizeChange #-} +testingSizeChange :: + (Monad m) => + -- | Decreased + sizeChange -> + -- | Didn't change + sizeChange -> + -- | Increased + sizeChange -> + Focus a m b -> + Focus a m (b, sizeChange) +testingSizeChange dec none inc (Focus absent present) = + Focus newAbsent newPresent + where + newAbsent = do + (output, change) <- absent + let sizeChange = case change of + Set _ -> inc + _ -> none + in return ((output, sizeChange), change) + newPresent element = do + (output, change) <- present element + let sizeChange = case change of + Remove -> dec + _ -> none + in return ((output, sizeChange), change) + +-- * STM + +-- | +-- Focus on the contents of a TVar. +{-# INLINE onTVarValue #-} +onTVarValue :: Focus a STM b -> Focus (TVar a) STM b +onTVarValue (Focus concealA presentA) = Focus concealTVar presentTVar + where + concealTVar = concealA >>= traverse interpretAChange + where + interpretAChange = \case + Leave -> return Leave + Set !a -> Set <$> newTVar a + Remove -> return Leave + presentTVar var = readTVar var >>= presentA >>= traverse interpretAChange + where + interpretAChange = \case + Leave -> return Leave + Set !a -> writeTVar var a $> Leave + Remove -> return Remove diff --git a/library/Focus/Prelude.hs b/library/Focus/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Focus/Prelude.hs @@ -0,0 +1,74 @@ +module Focus.Prelude + ( module Exports, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Cont as Exports hiding (callCC, shift) +import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT) +import Control.Monad.Trans.Maybe as Exports +import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), ask, mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT) +import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT) +import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter) +import Data.Bits as Exports +import Data.Bool as Exports +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Compose as Exports +import Data.Functor.Identity as Exports +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), Last (..)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Semigroup as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import Numeric as Exports +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,69 @@ +module Main where + +import qualified Focus +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (choose) + +main :: IO () +main = + defaultMain + $ testGroup "" + $ [ testCase "Monadically composed lookup and insert (https://github.com/nikita-volkov/stm-containers/issues/25)" + $ let Focus.Focus absent present = do + prev <- Focus.lookup + Focus.insert "one" + pure (isJust prev) + in do + assertEqual "" (True, Focus.Set "one") $ runIdentity (present "zero") + assertEqual "" (False, Focus.Set "one") $ runIdentity absent, + testCase "Applicatively composed lookup and insert" + $ let Focus.Focus absent present = (isJust <$> Focus.lookup) <* Focus.insert "one" + in do + assertEqual "" (True, Focus.Set "one") $ runIdentity (present "zero") + assertEqual "" (False, Focus.Set "one") $ runIdentity absent, + testCase "Applicatively composed pure and insert" + $ let Focus.Focus absent present = pure () <* Focus.insert "one" + in do + assertEqual "" ((), Focus.Set "one") (runIdentity (present "zero")) + assertEqual "" ((), Focus.Set "one") (runIdentity absent), + testCase "insert" + $ let Focus.Focus absent present = Focus.insert "one" + in do + assertEqual "" ((), Focus.Set "one") (runIdentity (present "zero")) + assertEqual "" ((), Focus.Set "one") (runIdentity absent), + testCase "alter" + $ let f :: Maybe String -> Maybe String + f = const Nothing + Focus.Focus absent present = Focus.alter f + in do + assertEqual "" ((), Focus.Remove) (runIdentity (present "zero")) + assertEqual "" ((), Focus.Leave) (runIdentity absent), + testCase "update" + $ let f :: String -> Maybe String + f = const Nothing + Focus.Focus absent present = Focus.update f + in do + assertEqual "" ((), Focus.Remove) (runIdentity (present "zero")) + assertEqual "" ((), Focus.Leave) (runIdentity absent), + testCase "updateM" + $ let f :: String -> Identity (Maybe String) + f = const (pure Nothing) + Focus.Focus absent present = Focus.updateM f + in do + assertEqual "" ((), Focus.Remove) (runIdentity (present "zero")) + assertEqual "" ((), Focus.Leave) (runIdentity absent), + testCase "delete" + $ let Focus.Focus absent present = Focus.delete + in do + assertEqual "" ((), Focus.Remove) (runIdentity (present "zero")) + assertEqual "" ((), Focus.Leave @()) (runIdentity absent), + testCase "Monadically composed lookup and delete (https://github.com/nikita-volkov/focus/issues/7)" + $ let Focus.Focus absent present = do + a <- Focus.lookup + Focus.delete + pure a + in do + assertEqual "" (Just (), Focus.Remove) (runIdentity (present ())) + assertEqual "" (Nothing @(), Focus.Leave) (runIdentity absent) + ]