packages feed

focus 0.1.5.2 → 1.0.3.2

raw patch · 5 files changed

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
focus.cabal view
@@ -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 <nikita.y.volkov@mail.ru>-maintainer:-  Nikita Volkov <nikita.y.volkov@mail.ru>-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 <nikita.y.volkov@mail.ru>+maintainer:    Nikita Volkov <nikita.y.volkov@mail.ru>+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
library/Focus.hs view
@@ -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.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:adjust adjust>@.-{-# INLINE adjust #-}-adjust :: (a -> a) -> Strategy a ()-adjust f = maybe ((), Keep) (\a -> ((), Replace (f a)))+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:member member>@.+{-# INLINE member #-}+member :: (Monad m) => Focus a m Bool+member = fmap (maybe False (const True)) lookup  -- | -- Reproduces the behaviour of--- @Data.Map.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:update update>@.-{-# INLINE update #-}-update :: (a -> Maybe a) -> Strategy a ()-update f = maybe ((), Keep) (\a -> ((), maybe Remove Replace (f a)))+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:lookup lookup>@.+{-# 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.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:alter alter>@.-{-# INLINE alter #-}-alter :: (Maybe a -> Maybe a) -> Strategy a ()-alter f = ((),) . maybe Remove Replace . f+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:findWithDefault findWithDefault>@+-- 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.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:insert insert>@.+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:delete delete>@.+{-# 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.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:insert insert>@. {-# 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.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:delete delete>@.-{-# INLINE delete #-}-delete :: Strategy a ()-delete = const ((), Remove)+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:insertWith insertWith>@+-- 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.<http://hackage.haskell.org/package/containers-0.5.5.1/docs/Data-Map-Lazy.html#v:lookup lookup>@.-{-# INLINE lookup #-}-lookup :: Strategy a (Maybe a)-lookup r = (r, Keep)+-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:alter alter>@.+{-# 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.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:adjust adjust>@.+{-# 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.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:update update>@.+{-# 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
+ library/Focus/Prelude.hs view
@@ -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, (.))
+ test/Main.hs view
@@ -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)+      ]