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,59 +1,102 @@ -name: focus -version: 1.0.3 -synopsis: A general abstraction for manipulating elements of container data structures +cabal-version: 3.0 +name: focus +version: 1.0.3.1 +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 +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 + 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 - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLists, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 - exposed-modules: - Focus - other-modules: - Focus.Prelude + import: language-settings + hs-source-dirs: library + exposed-modules: Focus + other-modules: Focus.Prelude build-depends: - base >=4.11 && <5, - transformers >=0.5 && <0.6 + , base >=4.11 && <5 + , transformers >=0.5 && <0.7 test-suite test - type: exitcode-stdio-1.0 + import: language-settings + type: exitcode-stdio-1.0 hs-source-dirs: test - default-extensions: BangPatterns, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, NoImplicitPrelude, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies - default-language: Haskell2010 - main-is: - Main.hs + main-is: Main.hs build-depends: - focus, - QuickCheck >=2.8.1 && <3, - quickcheck-instances >=0.3.11 && <0.4, - rerebase <2, - tasty >=0.12 && <2, - tasty-hunit >=0.9 && <0.11, - tasty-quickcheck >=0.9 && <0.11 + , 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,25 +1,23 @@ module Focus where -import Focus.Prelude hiding (adjust, update, alter, insert, delete, lookup) - - -{-| -Abstraction over the modification of an element of a datastructure. - -It is composable using the standard typeclasses, e.g.: +import Focus.Prelude hiding (delete, insert, lookup) ->lookupAndDelete :: Monad m => Focus a m (Maybe a) ->lookupAndDelete = lookup <* delete --} +-- | +-- 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)) -deriving instance Functor m => Functor (Focus element m) +deriving instance (Functor m) => Functor (Focus element m) -instance Monad m => Applicative (Focus element m) where +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 +instance (Monad m) => Monad (Focus element m) where return = pure (>>=) (Focus lAbsent lPresent) rk = Focus absent present @@ -44,15 +42,17 @@ 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 Change a = - Leave {-^ Produce no changes -} | - Remove {-^ Delete it -} | - Set a {-^ Set its value to the provided one -} +-- | +-- What to do with the focused value. +-- +-- The interpretation of the commands is up to the context APIs. +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 @@ -64,241 +64,204 @@ instance Monoid (Change a) where mempty = Leave - -- * Pure functions -------------------------- -- ** Reading functions -------------------------- -{-| -Reproduces the behaviour of -@Data.Map.@. --} +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE member #-} -member :: Monad m => Focus a m Bool +member :: (Monad m) => Focus a m Bool member = fmap (maybe False (const True)) lookup -{-| -Reproduces the behaviour of -@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 [1] lookup #-} +lookup :: (Monad m) => Focus a m (Maybe a) +lookup = cases (Nothing, Leave) (\a -> (Just a, Leave)) -{-| -Reproduces the behaviour of -@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)) +-- | +-- Reproduces the behaviour of +-- @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.@. --} -{-# INLINE[1] delete #-} -delete :: Monad m => Focus a m () +-- | +-- Reproduces the behaviour of +-- @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'@. --} +-- | +-- Lookup an element and delete it if it exists. +-- +-- Same as @'lookup' <* 'delete'@. {-# RULES - "lookup <* delete" [~1] lookup <* delete = lookupAndDelete +"lookup <* delete" [~1] lookup <* delete = lookupAndDelete #-} + {-# INLINE lookupAndDelete #-} -lookupAndDelete :: Monad m => Focus a m (Maybe a) -lookupAndDelete = cases (Nothing, Leave) (\ element -> (Just element, Remove)) +lookupAndDelete :: (Monad m) => Focus a m (Maybe a) +lookupAndDelete = cases (Nothing, Leave) (\element -> (Just element, Remove)) -{-| -Reproduces the behaviour of -@Data.Map.@. --} +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE insert #-} -insert :: Monad m => a -> Focus a m () +insert :: (Monad m) => a -> Focus a m () insert a = unitCases (Set a) (const (Set a)) -{-| -Reproduces the behaviour of -@Data.Map.@ -with a better name. --} +-- | +-- Reproduces the behaviour of +-- @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) +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.@. --} +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE alter #-} -alter :: Monad m => (Maybe a -> Maybe a) -> Focus a m () +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.@. --} +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE adjust #-} -adjust :: Monad m => (a -> a) -> Focus a m () +adjust :: (Monad m) => (a -> a) -> Focus a m () adjust fn = unitCases Leave (Set . fn) -{-| -Reproduces the behaviour of -@Data.Map.@. --} +-- | +-- Reproduces the behaviour of +-- @Data.Map.@. {-# INLINE update #-} -update :: Monad m => (a -> Maybe a) -> Focus a m () +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) +-- | +-- 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) +-- | +-- 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) +-- | +-- 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. --} +-- | +-- 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 :: (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. --} +-- | +-- 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)) - +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)) +-- | +-- 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'. --} +-- | +-- A monadic version of 'insert'. {-# INLINE insertM #-} -insertM :: Monad m => m a -> Focus a m () +insertM :: (Monad m) => m a -> Focus a m () insertM aM = unitCasesM (fmap Set aM) (const (fmap Set aM)) -{-| -A monadic version of 'insertOrMerge'. --} +-- | +-- 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')) +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'. --} +-- | +-- A monadic version of 'alter'. {-# INLINE alterM #-} -alterM :: Monad m => (Maybe a -> m (Maybe a)) -> Focus a m () +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'. --} +-- | +-- A monadic version of 'adjust'. {-# INLINE adjustM #-} -adjustM :: Monad m => (a -> m a) -> Focus a m () +adjustM :: (Monad m) => (a -> m a) -> Focus a m () adjustM fn = updateM (fmap Just . fn) -{-| -A monadic version of 'update'. --} +-- | +-- A monadic version of 'update'. {-# INLINE updateM #-} -updateM :: Monad m => (a -> m (Maybe a)) -> Focus a m () +updateM :: (Monad m) => (a -> m (Maybe a)) -> Focus a m () updateM fn = unitCasesM (return Leave) (fmap (maybe Remove Set) . fn) -- ** Construction utils -------------------------- -{-| -Lift monadic functions which handle the cases of presence and absence of the element. --} +-- | +-- Lift monadic functions which handle the cases of presence and absence of the element. {-# INLINE casesM #-} -casesM :: Monad m => m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b +casesM :: m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b casesM sendNone sendSome = Focus sendNone sendSome -{-| -Lift monadic functions which handle the cases of presence and absence of the element and produce no result. --} +-- | +-- 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)) - +unitCasesM :: (Monad m) => m (Change a) -> (a -> m (Change a)) -> Focus a m () +unitCasesM sendNone sendSome = Focus (fmap ((),) sendNone) (\a -> fmap ((),) (sendSome a)) -- * Composition -------------------------- -{-| -Map the Focus input. --} +-- | +-- 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) - +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 -------------------------- -{-| -Extends the output with the input. --} +-- | +-- Extends the output with the input. {-# INLINE extractingInput #-} -extractingInput :: Monad m => Focus a m b -> Focus a m (b, Maybe a) +extractingInput :: (Monad m) => Focus a m b -> Focus a m (b, Maybe a) extractingInput (Focus absent present) = Focus newAbsent newPresent where @@ -309,11 +272,10 @@ (b, change) <- present element return ((b, Just element), change) -{-| -Extends the output with the change performed. --} +-- | +-- Extends the output with the change performed. {-# INLINE extractingChange #-} -extractingChange :: Monad m => Focus a m b -> Focus a m (b, Change a) +extractingChange :: (Monad m) => Focus a m b -> Focus a m (b, Change a) extractingChange (Focus absent present) = Focus newAbsent newPresent where @@ -324,11 +286,10 @@ (b, change) <- present element return ((b, change), change) -{-| -Extends the output with a projection on the change that was performed. --} +-- | +-- 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 :: (Monad m) => (Change a -> c) -> Focus a m b -> Focus a m (b, c) projectingChange fn (Focus absent present) = Focus newAbsent newPresent where @@ -339,35 +300,32 @@ (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. --} +-- | +-- 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 :: (Monad m) => Focus a m b -> Focus a m (b, Bool) testingIfModifies = - projectingChange $ \ case + projectingChange $ \case Leave -> False _ -> True -{-| -Extends the output with a flag, -signaling whether the 'Remove' change has been introduced. --} +-- | +-- 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 :: (Monad m) => Focus a m b -> Focus a m (b, Bool) testingIfRemoves = - projectingChange $ \ case + 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. --} +-- | +-- 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 :: (Monad m) => Focus a m b -> Focus a m (b, Bool) testingIfInserts (Focus absent present) = Focus newAbsent newPresent where @@ -376,16 +334,24 @@ let testResult = case change of Set _ -> True _ -> False - in return ((output, testResult), change) + 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. --} +-- | +-- Extend the output with a flag, signaling how the size will be affected by the change. {-# INLINE testingSizeChange #-} -testingSizeChange :: Monad m => sizeChange {-^ Decreased -} -> sizeChange {-^ Didn't change -} -> sizeChange {-^ Increased -} -> Focus a m b -> Focus a m (b, sizeChange) +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 @@ -394,31 +360,31 @@ let sizeChange = case change of Set _ -> inc _ -> none - in return ((output, sizeChange), change) + 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) - + in return ((output, sizeChange), change) -- * STM -------------------------- -{-| -Focus on the contents of a TVar. --} +-- | +-- 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 +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 --- a/library/Focus/Prelude.hs +++ b/library/Focus/Prelude.hs @@ -1,20 +1,24 @@ module Focus.Prelude -( - module Exports, -) + ( module Exports, + ) where --- base -------------------------- 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 (mapM_, sequence_, forM_, msum, mapM, sequence, forM) -import Control.Monad.IO.Class 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 @@ -27,17 +31,19 @@ import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports -import Data.Int as Exports +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 (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +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 (Last(..), First(..)) +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.Semigroup 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 @@ -48,13 +54,12 @@ import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports -import Foreign.Storable as Exports hiding (sizeOf, alignment) -import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) -import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +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 Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports @@ -63,21 +68,7 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) -import Text.Printf as Exports (printf, hPrintf) -import Text.Read as Exports (Read(..), readMaybe, readEither) +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports - --- transformers -------------------------- -import Control.Monad.IO.Class as Exports -import Control.Monad.Trans.Class as Exports -import Control.Monad.Trans.Cont as Exports hiding (shift, callCC) -import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE) -import Control.Monad.Trans.Maybe as Exports -import Control.Monad.Trans.Reader as Exports (Reader, ask, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT) -import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT) -import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT) -import Data.Functor.Compose as Exports -import Data.Functor.Identity 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 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,83 +1,69 @@ module Main where -import Prelude hiding (choose) -import Test.QuickCheck.Instances +import qualified Focus import Test.Tasty -import Test.Tasty.Runners import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import qualified Test.QuickCheck as QuickCheck -import qualified Test.QuickCheck.Property as QuickCheck -import qualified Focus - +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) - ] + 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) + ]