diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright © 2014, 2015 Denis Firsov, © 2014, 2015 Wolfgang Jeltsch +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + • Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + • 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. + + • Neither the name of the copyright holders nor the names of the + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDERS 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,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/incremental-computing.cabal b/incremental-computing.cabal new file mode 100644 --- /dev/null +++ b/incremental-computing.cabal @@ -0,0 +1,83 @@ +Name: incremental-computing +Version: 0.0.0.0 +Cabal-Version: >= 1.16 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: © 2014, 2015 Denis Firsov; © 2014, 2015 Wolfgang Jeltsch +Author: Wolfgang Jeltsch +Maintainer: wolfgang@cs.ioc.ee +Stability: provisional +Homepage: http://darcs.wolfgang.jeltsch.info/haskell/incremental-computing +Package-URL: http://hackage.haskell.org/packages/archive/incremental-computing/0.0.0.0/incremental-computing-0.0.0.0.tar.gz +Synopsis: Incremental computing +Description: This package is about incremental computing. +Category: Data +Tested-With: GHC == 7.8.3 + +Source-Repository head + + Type: darcs + Location: http://darcs.wolfgang.jeltsch.info/haskell/incremental-computing/main + +Source-Repository this + + Type: darcs + Location: http://darcs.wolfgang.jeltsch.info/haskell/incremental-computing/main + Tag: incremental-computing-0.0.0.0 + +Library + + Build-Depends: base >= 3.0 && < 5, + containers >= 0.1 && < 0.6, + dlist >= 0.7 && < 0.8, + fingertree >= 0.1 && < 0.2, + order-maintenance >= 0.0 && < 0.1, + transformers >= 0.3 && < 0.5 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + GeneralizedNewtypeDeriving + MultiParamTypeClasses + RankNTypes + TypeFamilies + TypeOperators + + if impl(ghc >= 7.8) { + Default-Extensions: AutoDeriveTypeable + } + + Exposed-Modules: Data.Incremental + Data.Incremental.Sequence + Data.Incremental.Tuple + Data.MultiChange + + HS-Source-Dirs: src/library + +Test-Suite sequence-tests + + Type: detailed-0.9 + + Build-Depends: base >= 3.0 && < 5, + Cabal >= 1.16 && < 2, + cabal-test-quickcheck >= 0.1 && < 0.2, + containers >= 0.1 && < 0.6, + QuickCheck >= 2.6 && < 3, + incremental-computing == 0.0.0.0 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + GeneralizedNewtypeDeriving + StandaloneDeriving + TypeFamilies + TypeOperators + + Other-Extensions: UndecidableInstances + + Test-Module: TestSuite.Sequence + + Other-Modules: TestSuite + + HS-Source-Dirs: src/test-suites diff --git a/src/library/Data/Incremental.hs b/src/library/Data/Incremental.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental.hs @@ -0,0 +1,348 @@ +module Data.Incremental ( + + -- * Changes + + Change (Value, ($$)), + PrimitiveChange (Keep, ReplaceBy), + + -- * Transformations + + Trans, + TransProc, + + -- ** Construction + + simpleTrans, + stateTrans, + stTrans, + trans, + + -- ** Deconstruction + + runTrans, + toFunction, + toSTProc, + + -- ** Utilities + + const, + fromFunction, + sanitize, + + -- * Changeables + + Changeable (DefaultChange), + type (->>) + +) where + +-- Prelude + +import Prelude hiding (id, (.), const) +import qualified Prelude + +-- Control + +import Control.Category +import Control.Monad.ST.Lazy +import Control.Monad.ST.Lazy.Unsafe + +-- Data + +import Data.Monoid +import Data.Functor.Identity +import Data.STRef.Lazy + +infixr 0 $$ +infixr 0 ->> + +{-NOTE: + Our policy regarding class constraints with Change and Changeable is as + follows: + + • Global values that are about changes directly and do not use ($$) (which + are almost all of them) should not have Change constraints. Adding all + these change constraints everywhere would give us nothing and only + introduce clutter and possibly performance issues. + + • Global values that are about changeables (which first and foremost + includes all that are about (->>)) should have Changeable constraints, + because this ensures that standard changes are monoids and the value + type of standard changes is the type that we started with. +-} + +-- * Changes + +class Change p where + + type Value p :: * + + -- NOTE: Operator $$ is at least not used in the base library. + ($$) :: p -> Value p -> Value p + +data PrimitiveChange a = Keep | ReplaceBy a deriving (Show, Read) + +instance Functor PrimitiveChange where + + fmap _ Keep = Keep + fmap fun (ReplaceBy val) = ReplaceBy (fun val) + +instance Monoid (PrimitiveChange a) where + + mempty = Keep + + Keep `mappend` change = change + ReplaceBy val `mappend` _ = ReplaceBy val + +instance Change (PrimitiveChange a) where + + type Value (PrimitiveChange a) = a + + Keep $$ val = val + ReplaceBy val $$ _ = val + +-- * Transformations + +newtype Trans p q = Trans ((Value p, [p]) -> (Value q, [q])) + +instance Category Trans where + + id = Trans id + + Trans conv2 . Trans conv1 = Trans (conv2 . conv1) + +type TransProc m p q = Value p -> m (Value q, p -> m q) + +-- ** Construction + +simpleTrans :: (Value p -> Value q) -> (p -> q) -> Trans p q +simpleTrans fun prop = trans (\ cont -> runIdentity (cont transProc)) where + + transProc val = return (fun val, return . prop) + +stateTrans :: (Value p -> (Value q, s)) -> (p -> s -> (q, s)) -> Trans p q +stateTrans init prop = stTrans (\ val -> do + let (val', initState) = init val + stateRef <- newSTRef initState + let stProp change = do + oldState <- readSTRef stateRef + let (change', newState) = prop change oldState + writeSTRef stateRef newState + return change' + return (val', stProp)) + +stTrans :: (forall s . TransProc (ST s) p q) -> Trans p q +stTrans transProc = trans (\ cont -> runST (cont transProc)) + +{-NOTE: + ST with OrderT layers around can be run as follows: + + transNested :: (forall o1 ... on s . + TransProc (OrderT o1 (... (OrderT on (ST s)))) p q) + -> Trans p q + transNested transProc = trans (\ cont -> runST ( + evalOrderT ( + ... ( + evalOrderT (cont transProc))))) +-} + +{-FIXME: + We have to mention in the documentation that the monad is supposed to be + lazy. If it is strict, the constructed transformation trans will (probably) + have the following properties: + + • Reducing any expression runTrans trans valAndChanges to WHNF results in + the initialization being run and the constructed propagator being run on + all the changes. + + • The expression toSTProc trans is a processor that always yields ⊥ as the + output value and constructs propagators that always yield ⊥ as the + output change. +-} +trans :: (forall r . (forall m . Monad m => TransProc m p q -> m r) -> r) + -> Trans p q +trans cpsProcAndRun = errorIfStrictMonad `seq` Trans conv where + + errorIfStrictMonad = cpsProcAndRun $ + Prelude.const (strictMonadError >> return ()) + + strictMonadError = error "Data.Incremental: \ + \Transformation processor uses strict monad" + + conv valAndChanges = cpsProcAndRun $ + \ transProc -> monadicConv transProc valAndChanges + + monadicConv transProc ~(val, changes) = do + ~(val', prop) <- transProc val + changes' <- mapM prop changes + return (val', changes') + +-- ** Deconstruction + +runTrans :: Trans p q -> (Value p, [p]) -> (Value q, [q]) +runTrans (Trans conv) = conv + +toFunction :: Trans p q -> (Value p -> Value q) +toFunction (Trans conv) val = fst (conv (val, undefined)) + +{-FIXME: + We have to mention the following in the documentation: + + The function toSTProc . stTrans is not the identity. A computation in + the original value of type forall s . TransProc (ST s) may yield an + undefined state, but for computations in the constructed value, + undefinedness can only occur in the values they output. + + On the other hand, stTrans . toSTProc is the identity. [At least, it + should be.] +-} +{-FIXME: + It is crucial that toSTProc cannot be called on functions of type + + (Value p, [p]) -> (Value q, [q]) , + + but only on transformations, which correspond only to sensible, in + particular causal, functions. + + Take, for example, the following function: + + \ ~(val, ~(change1 : ~(change2 : rest))) -> (val, change2 : change1 : rest) + + (Maybe, we do not even need to use lazy patterns.) If we would apply a + function like toSTProc to it, and apply runTrans to the result, we would get + a function that is not referentially transparent. Let this function be + called f. Let us proceed as follows: + + let input = (False, [ReplaceBy False, ReplaceBy True]) + let output = f input + let changes' = snd output + let change1' = changes' !! 0 + let change2' = changes' !! 1 + + If we now evaluate change1', we will hit ⊥, because the second input change + has not been written into the channel. However, if we first evaluate + change2' and then change1', then change1' will evaluate to ReplaceBy True. + + This particular problem should not occur with our toSTProc, which only works + with transformations. If a user would reimplement toSTProc such that it + works with arbitrary functions of the above-mentioned type, he would have to + use unsafeInterleaveST directly, where there would be no guarantees anyhow. + + That said, we have to analyze very carefully whether our toSTProc is really + completely safe. Only if it is, we should declare a module that contains it + trustworthy (in the sense of Safe Haskell). We have to take into account + that trans works with arbitrary runnable monad families and an instantiation + of the Monad class could be bogus. The argument that running a + transformation always yields causal functions relies on the assumption that + the output of the first argument of (>>=) cannot depend on data that is only + contained in the second argument of (>>=). Maybe, this assumption can be + broken with a bogus Monad instance. But maybe, parametricity ensures that + this assumption holds. +-} + +toSTProc :: Trans p q -> TransProc (ST s) p q +toSTProc (Trans conv) val = do + (chan, changes) <- newChannel + let (val', changes') = conv (val, changes) + remainderRef <- newSTRef changes' + let prop change = do + writeChannel chan change + next : further <- readSTRef remainderRef + writeSTRef remainderRef further + return next + return (val', prop) + +-- ** Utilities + +const :: Monoid q => Value q -> Trans p q +const val = simpleTrans (Prelude.const val) (Prelude.const mempty) + +fromFunction :: (a -> b) -> Trans (PrimitiveChange a) (PrimitiveChange b) +fromFunction fun = simpleTrans fun (fmap fun) + +sanitize :: Eq a => Trans (PrimitiveChange a) (PrimitiveChange a) +sanitize = stateTrans init prop where + + init val = (val, val) + + prop Keep state = (Keep, state) + prop (ReplaceBy val) state = if val == state + then (Keep, state) + else (ReplaceBy val, val) + +-- * Changeables + +class (Monoid (DefaultChange a), + Change (DefaultChange a), + Value (DefaultChange a) ~ a) => + Changeable a where + + type DefaultChange a :: * + type DefaultChange a = PrimitiveChange a + +instance Changeable Bool + +instance Changeable Int + +{-FIXME: + Add default instance declarations for all remaining Prelude types and + replace them by something more decent if there is something more decent. +-} + +type a ->> b = Trans (DefaultChange a) (DefaultChange b) + +-- * Channels in the ST monad + +data Cell s a = Cell a (CellRef s a) + +type CellRef s a = STRef s (Cell s a) + +type Channel s a = STRef s (CellRef s a) + +newChannel :: ST s (Channel s a, [a]) +newChannel = do + cellRef <- newSTRef undefined + chan <- newSTRef cellRef + let getContents cellRef = unsafeInterleaveST $ do + Cell val cellRef' <- readSTRef cellRef + vals <- getContents cellRef' + return (val : vals) + -- FIXME: Is this use of unsafeInterleaveST safe? + contents <- getContents cellRef + return (chan, contents) + +writeChannel :: Channel s a -> a -> ST s () +writeChannel chan val = do + cellRef <- readSTRef chan + cellRef' <- newSTRef undefined + writeSTRef cellRef (Cell val cellRef') + writeSTRef chan cellRef' + +{-FIXME: + Is there already an implementation of ST channels? +-} + +{-FIXME: + Remove Control.Monad.ST.Lazy.Unsafe from the import list, if the channel + code moves to its own module. +-} + +{-FIXME: + The following things are to be considered: + + • Does our framework correspond to update lenses? How is it related to + update lenses? Look at the slides of Tarmo’s seminar talk from + 11 September 2014. + + • Our work on order maintenance could be turned into a paper. Currently, + one has to read more than one paper to understand the algorithm (Dietz + and Sleator 1987; Willard 1986) and Dietz and Sleator (1987) do not + explain deletion. + + • The incrementalized version of maps cannot allow conversion to sequences + of key–value pairs, but only to sequences of values, because if the map + was created from a sequence and was then converted to a sequence of + key–value pairs, the choice of keys from equivalence classes of keys + would depend on the history of changes to the original sequence, not + just on the current value of the sequence. +-} diff --git a/src/library/Data/Incremental/Sequence.hs b/src/library/Data/Incremental/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental/Sequence.hs @@ -0,0 +1,622 @@ +module Data.Incremental.Sequence ( + + -- * Type + + Seq, + {-NOTE: + By re-exporting Seq, we get the definition of DefaultChange for Seq into + the documentation generated by Haddock. + -} + + -- * Changes + + insert, + delete, + shift, + changeAt, + + -- * Atomic changes + + AtomicChange (Insert, Delete, Shift, ChangeAt), + normalizeAtomicChange, + + -- * Transformations + + singleton, + fromPair, + cat, + null, + length, + map, + map', + concat, + concatMap, + gate, + gate', + filter, + filter', + reverse, + sort, + sortBy + +) where + +-- Prelude + +import Prelude hiding ( + id, + (.), + null, + length, + map, + concat, + concatMap, + filter, + reverse, + foldl) +import qualified Prelude + +-- Control + +import Control.Category +import Control.Monad.ST.Lazy +import Control.Monad.Trans.Class +import Control.Monad.Trans.Order + +-- Data + +import Data.Monoid +import Data.Foldable (foldl, asum, toList) +import Data.Traversable (traverse) +import Data.FingerTree (FingerTree, Measured (measure)) +import qualified Data.FingerTree as FingerTree +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.STRef.Lazy +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple + +{-NOTE: + Naming policy: + + • Data of argument transformations gets additional text, like “elem”. + + • Data related to input of a transformation gets an ordinary identifier, + and the corresponding data related to output gets the same identifier + with a prime. + + • Data that refers to the situation after applying a change gets an + identifier that starts with “new”, and the corresponding data that + refers to the situation before applying this change gets the + corresponding identifier that starts with “old”. +-} + +-- * Changes + +instance Changeable a => Changeable (Seq a) where + + type DefaultChange (Seq a) = MultiChange (AtomicChange a) + +insert :: Int -> Seq a -> DefaultChange (Seq a) +insert ix seq = MultiChange.singleton (Insert ix seq) + +delete :: Int -> Int -> DefaultChange (Seq a) +delete ix len = MultiChange.singleton (Delete ix len) + +shift :: Int -> Int -> Int -> DefaultChange (Seq a) +shift src len tgt = MultiChange.singleton (Shift src len tgt) + +changeAt :: Int -> DefaultChange a -> DefaultChange (Seq a) +changeAt ix change = MultiChange.singleton (ChangeAt ix change) + +-- * Atomic changes + +data AtomicChange a = Insert !Int (Seq a) + | Delete !Int !Int + | Shift !Int !Int !Int + | ChangeAt !Int (DefaultChange a) +{-FIXME: + Are these strictness annotations sensible? Should the sequence be strict? +-} + +{-NOTE: + Change application for sequences is total. It uses forms of saturation to + achieve this. All the transformations must work correctly also in the + saturation cases. At the time of writing, they do. +-} +instance Changeable a => Change (AtomicChange a) where + + type Value (AtomicChange a) = Seq a + + Insert ix seq' $$ seq = applyInsert ix seq' seq + + Delete ix len $$ seq = applyDelete ix len seq + + Shift src len tgt $$ seq = applyShift src len tgt seq + + ChangeAt ix change $$ seq + | indexInBounds (Seq.length seq) ix + = front >< (change $$ elem) Seq.<| rear + | otherwise + = seq where + + (front, rest) = Seq.splitAt ix seq + + (elem Seq.:< rear) = Seq.viewl rest + +applyInsert :: Int -> Seq a -> Seq a -> Seq a +applyInsert ix seq' seq = front >< seq' >< rear where + + (front, rear) = Seq.splitAt ix seq + +applyDelete :: Int -> Int -> Seq a -> Seq a +applyDelete ix len seq = front >< rear where + + (front, rest) = Seq.splitAt ix seq + + (_, rear) = Seq.splitAt len rest + +applyShift :: Int -> Int -> Int -> Seq a -> Seq a +applyShift src len tgt seq = applyInsert tgt mid (front >< rear) where + + (front, rest) = Seq.splitAt src seq + + (mid, rear) = Seq.splitAt len rest + +normalizeAtomicChange :: Int -> AtomicChange a -> AtomicChange a +normalizeAtomicChange totalLen (Insert ix seq) = Insert ix' seq where + + ix' = normalizeIx totalLen ix + +normalizeAtomicChange totalLen (Delete ix len) = Delete ix' len' where + + (ix', len') = normalizeIxAndLen totalLen ix len + +normalizeAtomicChange totalLen (Shift src len tgt) = Shift src' len' tgt' where + + (src', len') = normalizeIxAndLen totalLen src len + + tgt' = normalizeIx (totalLen - len') tgt + +normalizeAtomicChange totalLen (ChangeAt ix change) = ChangeAt ix' change where + + ix' | indexInBounds totalLen ix = ix + | otherwise = totalLen + +normalizeIx :: Int -> Int -> Int +normalizeIx totalLen ix = (ix `max` 0) `min` totalLen + +normalizeIxAndLen :: Int -> Int -> Int -> (Int, Int) +normalizeIxAndLen totalLen ix len = (ix', len') where + + ix' = normalizeIx totalLen ix + + len' = (len `max` 0) `min` (totalLen - ix') + +noChange :: Changeable a => AtomicChange a +noChange = ChangeAt (-1) mempty + +changeLength :: AtomicChange a -> Int -> Int +changeLength (Insert _ seq) totalLength = totalLength + Seq.length seq +changeLength (Delete _ len) totalLength = totalLength - len +changeLength (Shift _ _ _) totalLength = totalLength +changeLength (ChangeAt _ _) totalLength = totalLength +-- NOTE: The given change must be normal. + +indexInBounds :: Int -> Int -> Bool +indexInBounds len ix = ix >= 0 && ix < len + +-- * Transformations + +-- ** Singleton construction + +singleton :: Changeable a => a ->> Seq a +singleton = simpleTrans Seq.singleton (changeAt 0) + +-- ** Two-element sequence construction + +fromPair :: Changeable a => (a, a) ->> Seq a +fromPair = MultiChange.map $ simpleTrans fun prop where + + fun ~(val1, val2) = Seq.fromList [val1, val2] + + prop (Tuple.First change) = ChangeAt 0 change + prop (Tuple.Second change) = ChangeAt 1 change + +-- ** Concatenation of two sequences + +cat :: Changeable a => (Seq a, Seq a) ->> Seq a +cat = concat . fromPair + +-- ** Length queries + +null :: Changeable a => Seq a ->> Bool +null = fromFunction (== 0) . length + +length :: Changeable a => Seq a ->> Int +length = MultiChange.composeMap $ stateTrans init prop where + + init seq = (len, len) where + + len = Seq.length seq + + prop change state = (ReplaceBy len', len') where + + normChange = normalizeAtomicChange state change + + len' = changeLength normChange state + +-- ** Mapping + +map :: (Changeable a, Changeable b) => (a ->> b) -> Seq a ->> Seq b +map trans = MultiChange.map $ stTrans (\ seq -> do + let elemProc = toSTProc trans + let seqInit seq = do + procOutputs <- traverse elemProc seq + return (fmap fst procOutputs, fmap snd procOutputs) + (seq', elemProps) <- seqInit seq + elemPropsRef <- newSTRef elemProps + let prop (Insert ix seq) = do + (seq', elemProps) <- seqInit seq + modifySTRef elemPropsRef (applyInsert ix elemProps) + return (Insert ix seq') + prop (Delete ix len) = do + modifySTRef elemPropsRef (applyDelete ix len) + return (Delete ix len) + prop (Shift src len tgt) = do + modifySTRef elemPropsRef (applyShift src len tgt) + return (Shift src len tgt) + prop (ChangeAt ix change) = do + elemProps <- readSTRef elemPropsRef + if indexInBounds (Seq.length elemProps) ix + then do + let elemProp = Seq.index elemProps ix + change' <- elemProp change + return (ChangeAt ix change') + else return noChange + return (seq', prop)) + +map' :: (Changeable a, DefaultChange a ~ PrimitiveChange a, + Changeable b, DefaultChange b ~ PrimitiveChange b) => + (a -> b) -> Seq a ->> Seq b +map' fun = MultiChange.map $ simpleTrans (fmap fun) prop where + + prop (Insert ix seq) = Insert ix (fmap fun seq) + prop (Delete ix len) = Delete ix len + prop (Shift src len tgt) = Shift src len tgt + prop (ChangeAt ix change) = ChangeAt ix (fmap fun change) + +-- ** Concatenation of multiple sequences + +seqConcat :: Seq (Seq a) -> Seq a +seqConcat = asum + +newtype ConcatStateElement = ConcatStateElement Int + +data ConcatStateMeasure = ConcatStateMeasure { + sourceLength :: Int, + targetLength :: Int + } + +instance Monoid ConcatStateMeasure where + + mempty = ConcatStateMeasure 0 0 + + mappend (ConcatStateMeasure srcLen1 tgtLen1) + (ConcatStateMeasure srcLen2 tgtLen2) = measure' where + + measure' = ConcatStateMeasure (srcLen1 + srcLen2) (tgtLen1 + tgtLen2) + +instance Measured ConcatStateMeasure ConcatStateElement where + + measure (ConcatStateElement elLen) = ConcatStateMeasure 1 elLen + +type ConcatState = FingerTree ConcatStateMeasure ConcatStateElement + +seqToConcatState :: Seq (Seq a) -> ConcatState +seqToConcatState = FingerTree.fromList . + toList . + fmap (ConcatStateElement . Seq.length) + +concat :: Changeable a => Seq (Seq a) ->> Seq a +concat = MultiChange.bind $ stateTrans init prop where + + init seq = (seqConcat seq, seqToConcatState seq) + + prop (Insert ix seq) state = (change', state') where + + (ix', front, rear) = splitAndTranslate ix state + + change' = insert ix' (seqConcat seq) + + state' = front <> seqToConcatState seq <> rear + + prop (Delete ix len) state = (change', state') where + + (ix', front, rest) = splitAndTranslate ix state + + (len', _, rear) = splitAndTranslate len rest + + change' = delete ix' len' + + state' = front <> rear + + prop (Shift src len tgt) state = (change', state') where + + (src', front, rest) = splitAndTranslate src state + + (len', mid, rear) = splitAndTranslate len rest + + (tgt', front', rear') = splitAndTranslate tgt (front <> rear) + + change' = shift src' len' tgt' + + state' = front' <> mid <> rear' + + prop (ChangeAt ix change) state + | indexInBounds len ix = (change', state') + | otherwise = (mempty, state) where + + len = sourceLength (measure state) + + (ix', front, rest) = splitAndTranslate ix state + + (ConcatStateElement elemLen FingerTree.:< rear) = FingerTree.viewl rest + + (change', elemLen') = foldl next (mempty, elemLen) change where + + next (curChange, curElemLen) atomic = (curChange', curElemLen') where + + normAtomic = normalizeAtomicChange curElemLen atomic + + shiftedNormAtomic = case normAtomic of + Insert elemIx seq + -> Insert (ix' + elemIx) seq + Delete elemIx curElemLen + -> Delete (ix' + elemIx) curElemLen + Shift elemSrc curElemLen elemTgt + -> Shift (ix' + elemSrc) curElemLen (ix' + elemTgt) + ChangeAt elemIx change + -> if indexInBounds curElemLen elemIx + then ChangeAt (ix' + elemIx) change + else noChange + + curChange' = MultiChange.singleton shiftedNormAtomic `mappend` + curChange + + curElemLen' = changeLength normAtomic curElemLen + -- NOTE: Strictness is not perfect. + -- FIXME: One line too wide. + + state' = front <> (ConcatStateElement elemLen' FingerTree.<| rear) + {-NOTE: + This is a bit fishy. Even if the inner change is illegal, we get a + non-⊥ state. So the state is not always a property of the original + value. If the original value is ⊥, the state might not be ⊥. + However, this should not result in violation of the main property + that changing and then transforming is the same as transforming and + then changing with the propagated change. We would propagate to + non-⊥ changes in the future, but applying these to ⊥ yields ⊥. The + latter might not always be the case, but it is the case for + sequences. + -} + + splitAndTranslate :: Int -> ConcatState -> (Int, ConcatState, ConcatState) + splitAndTranslate ix state = (ix', front, rear) where + + (front, rear) = FingerTree.split ((> ix) . sourceLength) state + + ix' = targetLength (measure front) + +-- ** Monadic bind + +concatMap :: (Changeable a, Changeable b) => (a ->> Seq b) -> Seq a ->> Seq b +concatMap trans = concat . map trans + +-- ** Gates + +gate :: Changeable a => (a ->> Bool) -> a ->> Seq a +gate prd = stTrans (\ val -> do + valRef <- newSTRef val + ~(accepted, prop) <- toSTProc prd val + acceptedRef <- newSTRef accepted + let prop' change = do + oldVal <- readSTRef valRef + let newVal = change $$ oldVal + writeSTRef valRef newVal + acceptedChange <- prop change + oldAccepted <- readSTRef acceptedRef + let newAccepted = acceptedChange $$ oldAccepted + writeSTRef acceptedRef newAccepted + return $ case (oldAccepted, newAccepted) of + (False, False) -> mempty + (False, True) -> insert 0 (Seq.singleton newVal) + (True, False) -> delete 0 1 + (True, True) -> changeAt 0 change + return (emptyOrSingleton accepted val, prop')) +{-FIXME: + Consider factoring out at least the update of values and accepted flags. +-} +{-FIXME: + Here we seem to use the apostrophe to distinguish between argument + transformation and result transformation, which does not seem to be coherent + with the rest of this module. +-} + +gate' :: (Changeable a, DefaultChange a ~ PrimitiveChange a) => + (a -> Bool) -> a ->> Seq a +gate' prd = stateTrans init prop where + + init val = (emptyOrSingleton accepted val, accepted) where + + accepted = prd val + + prop Keep oldAccepted = (mempty, oldAccepted) + prop (ReplaceBy val) oldAccepted = (change', newAccepted) where + + change' = case (oldAccepted, newAccepted) of + (False, False) -> mempty + (False, True) -> insert 0 (Seq.singleton val) + (True, False) -> delete 0 1 + (True, True) -> changeAt 0 (ReplaceBy val) + + newAccepted = prd val + +emptyOrSingleton :: Bool -> a -> Seq a +emptyOrSingleton accepted val | accepted = Seq.singleton val + | otherwise = Seq.empty + +-- ** Filtering + +filter :: Changeable a => (a ->> Bool) -> Seq a ->> Seq a +filter = concatMap . gate + +filter' :: (Changeable a, DefaultChange a ~ PrimitiveChange a) => + (a -> Bool) -> Seq a ->> Seq a +filter' = concatMap . gate' + +-- FIXME: Maybe add partition and partition'. + +-- ** Reversal + +reverse :: Changeable a => Seq a ->> Seq a +reverse = MultiChange.map $ stateTrans init prop where + + init seq = (Seq.reverse seq, Seq.length seq) + + prop change state = propNorm (normalizeAtomicChange state change) state + + propNorm change state = (propCore change state, changeLength change state) + + propCore (Insert ix seq) state = change' where + + change' = Insert (state - ix) (Seq.reverse seq) + + propCore (Delete ix len) state = change' where + + change' = Delete (state - (ix + len)) len + + propCore (Shift src len tgt) state = change' where + + change' = Shift (state - (src + len)) len (state - len - tgt) + + propCore (ChangeAt ix elemChange) state = change' where + + change' = ChangeAt (state - ix - 1) elemChange + +-- ** Sorting + +sort :: (Ord a, Changeable a) => Seq a ->> Seq a +sort = MultiChange.bind $ orderSTTrans (\ seq -> do + let seq' = Seq.sort seq + initTaggedSeq <- traverse (\ elem -> fmap ((,) elem) newMaximum) seq + let initTaggedSet = Set.fromList (toList initTaggedSeq) + taggedSeqRef <- lift $ newSTRef initTaggedSeq + taggedSetRef <- lift $ newSTRef initTaggedSet + let performInsert ix elem = do + taggedSeq <- lift $ readSTRef taggedSeqRef + let (front, rest) = Seq.splitAt ix taggedSeq + tag <- case Seq.viewl rest of + Seq.EmptyL -> newMaximum + (_, neighborTag) Seq.:< _ -> newBefore neighborTag + lift $ writeSTRef taggedSeqRef (front >< (elem, tag) Seq.<| rest) + oldTaggedSet <- lift $ readSTRef taggedSetRef + let newTaggedSet = Set.insert (elem, tag) oldTaggedSet + lift $ writeSTRef taggedSetRef newTaggedSet + return (Set.findIndex (elem, tag) newTaggedSet) + let performDelete ix = do + taggedSeq <- lift $ readSTRef taggedSeqRef + let (front, rest) = Seq.splitAt ix taggedSeq + let (elem, tag) Seq.:< rear = Seq.viewl rest + lift $ writeSTRef taggedSeqRef (front >< rear) + taggedSet <- lift $ readSTRef taggedSetRef + lift $ writeSTRef taggedSetRef + (Set.delete (elem, tag) taggedSet) + return (Set.findIndex (elem, tag) taggedSet) + let elemInsert ix elem = do + ix' <- performInsert ix elem + return (Insert ix' (Seq.singleton elem)) + let elemDelete ix = do + ix' <- performDelete ix + return (Delete ix' 1) + let elemShift src tgt = do + taggedSeq <- lift $ readSTRef taggedSeqRef + let elem = fst (Seq.index taggedSeq src) + src' <- performDelete src + tgt' <- performInsert tgt elem + return (Shift src' 1 tgt') + let propNorm (Insert ix seq) = do + changes' <- traverse (elemInsert ix) (Prelude.reverse (toList seq)) + return (MultiChange.fromList changes') + propNorm (Delete ix len) = do + changes' <- traverse elemDelete (replicate len ix) + return (MultiChange.fromList changes') + propNorm (Shift src len tgt) = (case compare src tgt of + LT -> genShifts (Prelude.reverse [0 .. len - 1]) + GT -> genShifts [0 .. len - 1] + EQ -> return mempty) where + + genShifts offsets = do + changes' <- traverse genShift offsets + return (MultiChange.fromList changes') + + genShift offset = elemShift (src + offset) (tgt + offset) + + propNorm (ChangeAt ix change) = do + taggedSeq <- lift $ readSTRef taggedSeqRef + if indexInBounds (Seq.length taggedSeq) ix + then do + let (oldElem, _) = Seq.index taggedSeq ix + let newElem = change $$ oldElem + src' <- performDelete ix + tgt' <- performInsert ix newElem + return (shift src' 1 tgt' `mappend` changeAt src' change) + else return mempty + let prop change = do + taggedSeq <- lift $ readSTRef taggedSeqRef + propNorm (normalizeAtomicChange (Seq.length taggedSeq) change) + return (seq', prop)) + +orderSTTrans :: (forall o s . TransProc (OrderT o (ST s)) p q) -> Trans p q +orderSTTrans transProc = trans (\ cont -> runST (evalOrderT (cont transProc))) + +sortBy :: Changeable a => (a -> a -> Ordering) -> Seq a ->> Seq a +sortBy compare = map fromOrderValue . sort . map (toOrderValue compare) +{-FIXME: + In the future, we maybe should have a sortBy that takes a compare + transformation instead of a compare function. +-} + +data OrderValue a = OrderValue (a -> a -> Ordering) a + +instance Eq (OrderValue a) where + + orderVal1 == orderVal2 = compare orderVal1 orderVal2 == EQ + +instance Ord (OrderValue a) where + + compare (OrderValue compare val1) (OrderValue _ val2) = compare val1 val2 + +newtype OrderChange p = OrderChange p deriving Monoid + +instance Change p => Change (OrderChange p) where + + type Value (OrderChange p) = OrderValue (Value p) + + OrderChange change $$ OrderValue compare val = OrderValue compare $ + change $$ val + +instance Changeable a => Changeable (OrderValue a) where + + type DefaultChange (OrderValue a) = OrderChange (DefaultChange a) + +toOrderValue :: Changeable a => (a -> a -> Ordering) -> a ->> OrderValue a +toOrderValue compare = simpleTrans (OrderValue compare) OrderChange + +fromOrderValue :: Changeable a => OrderValue a ->> a +fromOrderValue = simpleTrans (\ (OrderValue _ val) -> val) + (\ (OrderChange change) -> change) diff --git a/src/library/Data/Incremental/Tuple.hs b/src/library/Data/Incremental/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental/Tuple.hs @@ -0,0 +1,92 @@ +module Data.Incremental.Tuple ( + + {-NOTE: + We would have liked to re-export (,), like we re-export Seq from + Data.Incremental.Sequence. However, we could not find a way to + re-export (,). + -} + + -- * Changes + + first, + second, + + -- * Atomic changes + + AtomicChange (First, Second), + + -- * Transformations + + (&&&), + fst, + snd, + swap + +) where + +-- Prelude + +import Prelude hiding (fst, snd) +import qualified Prelude + +-- Data + +import Data.Monoid (Monoid (mempty, mappend)) +import qualified Data.Tuple as Tuple +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental + +-- * Changes + +instance (Changeable a, Changeable b) => Changeable (a, b) where + + type DefaultChange (a, b) = MultiChange (AtomicChange a b) + +first :: DefaultChange a -> DefaultChange (a, b) +first = MultiChange.singleton . First + +second :: DefaultChange b -> DefaultChange (a, b) +second = MultiChange.singleton . Second + +-- * Atomic changes + +data AtomicChange a b = First (DefaultChange a) | Second (DefaultChange b) + +instance (Changeable a, Changeable b) => Change (AtomicChange a b) where + + type Value (AtomicChange a b) = (a, b) + + First change $$ (val1, val2) = (change $$ val1, val2) + Second change $$ (val1, val2) = (val1, change $$ val2) + +-- * Transformations + +(&&&) :: (Changeable a, Changeable b, Changeable c) => + (a ->> b) -> (a ->> c) -> (a ->> (b, c)) +trans1 &&& trans2 = stTrans (\ val -> do + ~(val1, prop1) <- toSTProc trans1 val + ~(val2, prop2) <- toSTProc trans2 val + let prop change = do + change1 <- prop1 change + change2 <- prop2 change + return (first change1 `mappend` second change2) + return ((val1, val2), prop)) + +fst :: (Changeable a, Changeable b) => (a, b) ->> a +fst = MultiChange.composeMap $ simpleTrans Prelude.fst prop where + + prop (First change) = change + prop (Second _) = mempty + +snd :: (Changeable a, Changeable b) => (a, b) ->> b +snd = MultiChange.composeMap $ simpleTrans Prelude.snd prop where + + prop (First _) = mempty + prop (Second change) = change + +swap :: (Changeable a, Changeable b) => (a, b) ->> (b, a) +swap = MultiChange.map $ simpleTrans Tuple.swap prop where + + prop (First change) = Second change + prop (Second change) = First change diff --git a/src/library/Data/MultiChange.hs b/src/library/Data/MultiChange.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/MultiChange.hs @@ -0,0 +1,122 @@ +module Data.MultiChange ( + + -- * Type + + MultiChange, + + -- * Construction + + singleton, + fromList, + + -- * Monad structure + + map, + return, + join, + bind, + + -- * Multi composition + + compose, + composeMap + +) where + +-- Prelude + +import Prelude hiding (id, (.), map, return) +import qualified Prelude +{-FIXME: + After establishment of the Applicative–Monad proposal, we have to optionally + hide join. +-} + +-- Control + +import Control.Category +import Control.Arrow (second) +import Control.Monad (liftM) + +-- Data + +import Data.Monoid +import Data.Foldable as Foldable +import qualified Data.List as List +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Incremental + +-- * Type + +newtype MultiChange p = MultiChange (Dual (DList p)) deriving Monoid + +instance Show p => Show (MultiChange p) where + + showsPrec prec xs = showParen (prec > 10) $ + showString "fromList " . shows (toList xs) + -- NOTE: This is basically taken from Data.Sequence. + +instance Read p => Read (MultiChange p) where + + readsPrec prec = readParen (prec > 10) $ \ str -> do + ("fromList", rest) <- lex str + (list, rest') <- reads rest + Prelude.return (fromList list, rest') + -- NOTE: This is basically taken from Data.Sequence. + +instance Foldable MultiChange where + + foldMap fun (MultiChange (Dual dList)) = foldMap fun dList + + foldr next init (MultiChange (Dual dList)) = Foldable.foldr next init dList + +instance Change p => Change (MultiChange p) where + + type Value (MultiChange p) = Value p + + change $$ val = List.foldl' (flip ($$)) val (toList change) + +-- * Construction + +singleton :: p -> MultiChange p +singleton = MultiChange . Dual . DList.singleton + +{-NOTE: + The lists are “in diagramatic order” (first atomic change at the beginning). +-} + +fromList :: [p] -> MultiChange p +fromList = MultiChange . Dual . DList.fromList + +-- * Monad structure + +map :: Trans p q -> Trans (MultiChange p) (MultiChange q) +map trans = stTrans (\ val -> do + ~(val', prop) <- toSTProc trans val + let multiProp change = do + atomics' <- mapM prop (toList change) + Prelude.return (fromList atomics') + Prelude.return (val', multiProp)) + +return :: Trans p (MultiChange p) +return = simpleTrans id singleton + +join :: Trans (MultiChange (MultiChange p)) (MultiChange p) +join = compose + +bind :: Trans p (MultiChange q) -> Trans (MultiChange p) (MultiChange q) +bind = composeMap + +-- * Multi composition + +compose :: Monoid p => Trans (MultiChange p) p +compose = simpleTrans id (mconcat . reverse . toList) +{-FIXME: + Check whether the use of mconcat . reverse is questionable regarding space + usage or strictness. If it is, consider using foldr (flip mappend) mempty + instead. +-} + +composeMap :: Monoid q => Trans p q -> Trans (MultiChange p) q +composeMap trans = compose . map trans diff --git a/src/test-suites/TestSuite.hs b/src/test-suites/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/test-suites/TestSuite.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE UndecidableInstances #-} +module TestSuite ( + + -- * Changes + + AtomicAChange (DoubleAndAdd), + AtomicBChange (TripleAndAdd), + + -- * Test functions and transformations + + testTrans, + testFun, + testPrdTrans, + testPrdFun, + testCompare, + + -- * Test pattern + + transTest + +) where + +-- Prelude + +import Prelude hiding (id, (.)) + +-- Control + +import Control.Category +import Control.Applicative + +-- Data + +import Data.Foldable (toList) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple +import qualified Data.Incremental.Sequence as Seq + +-- Test + +import Test.QuickCheck +import Test.QuickCheck.Poly + +-- Distribution + +import Distribution.TestSuite +import Distribution.TestSuite.QuickCheck + +-- * Test data generation + +instance Arbitrary a => Arbitrary (Seq a) where + + arbitrary = fmap Seq.fromList arbitrary + + shrink seq = map Seq.fromList (shrink (toList seq)) + +-- * Changes + +-- ** Common changes + +instance Arbitrary a => Arbitrary (PrimitiveChange a) where + + arbitrary = frequency [(1, keepGen), (5, replaceGen)] where + + keepGen = return Keep + + replaceGen = fmap ReplaceBy arbitrary + + shrink Keep = [] + shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val) + +instance Arbitrary p => Arbitrary (MultiChange p) where + + arbitrary = fmap MultiChange.fromList arbitrary + + shrink change = map MultiChange.fromList (shrink (toList change)) + +-- ** Pair changes + +deriving instance (Show (DefaultChange a), Show (DefaultChange b)) => + Show (Tuple.AtomicChange a b) + +instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) => + Arbitrary (Tuple.AtomicChange a b) where + + arbitrary = oneof [firstGen, secondGen] where + + firstGen = fmap Tuple.First arbitrary + + secondGen = fmap Tuple.Second arbitrary + + shrink (Tuple.First change) = map Tuple.First (shrink change) + shrink (Tuple.Second change) = map Tuple.Second (shrink change) + +-- ** Sequence changes + +deriving instance (Show a, Show (DefaultChange a)) => Show (Seq.AtomicChange a) + +instance (Arbitrary a, Arbitrary (DefaultChange a)) => + Arbitrary (Seq.AtomicChange a) where + + arbitrary = oneof [insertGen, deleteGen, shiftGen, changeAtGen] where + + insertGen = liftA2 Seq.Insert arbitrary arbitrary + + deleteGen = liftA2 Seq.Delete arbitrary arbitrary + + shiftGen = liftA3 Seq.Shift arbitrary arbitrary arbitrary + + changeAtGen = liftA2 Seq.ChangeAt arbitrary arbitrary + + shrink (Seq.Insert ix seq) + = [Seq.Insert ix' seq' + | (ix', seq') <- shrink (ix, seq)] + shrink (Seq.Delete ix len) + = [Seq.Delete ix' len' + | (ix', len') <- shrink (ix, len)] + shrink (Seq.Shift src len tgt) + = [Seq.Shift src' len' tgt' + | (src', len', tgt') <- shrink (src, len, tgt)] + shrink (Seq.ChangeAt ix change) + = [Seq.ChangeAt ix' change' + | (ix', change') <- shrink (ix, change)] + +-- ** Element changes + +newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicAChange where + + type Value AtomicAChange = A + + DoubleAndAdd diff $$ A integer = A (2 * integer + diff) + +instance Changeable A where + + type DefaultChange A = MultiChange AtomicAChange + +deriving instance Ord A + +newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicBChange where + + type Value AtomicBChange = B + + TripleAndAdd diff $$ B integer = B (3 * integer + diff) + +instance Changeable B where + + type DefaultChange B = MultiChange AtomicBChange + +instance Changeable C + +-- * Test functions and transformations + +testTrans :: A ->> B +testTrans = MultiChange.map $ stateTrans init prop where + + init (A integer) = (B integer, integer) + + prop (DoubleAndAdd diff) state = (change', state') where + + change' = TripleAndAdd (diff - state) + + state' = 2 * state + diff + +testFun :: C -> C +testFun = id + +testPrdTrans :: A ->> Bool +testPrdTrans = MultiChange.composeMap $ stateTrans init prop where + + init (A integer) = (testPrd integer, integer) + + prop (DoubleAndAdd diff) state = (change', state') where + + change' = ReplaceBy (testPrd state') + + state' = 2 * state + diff + +testPrdFun :: C -> Bool +testPrdFun = testPrd . unC + +testPrd :: Integer -> Bool +testPrd = (>= 0) + +testCompare :: A -> A -> Ordering +testCompare (A integer1) (A integer2) = compare (integer1 `div` 3) + (integer2 `div` 3) + +-- * Test pattern + +transTest :: (Show a, Arbitrary a, Changeable a, + Show (DefaultChange a), Arbitrary (DefaultChange a), + Eq b, Changeable b) => + String -> (a ->> b) -> (a -> b) -> Test +transTest name trans fun = testProperty name prop where + + prop valAndChanges = map fun (applyChanges valAndChanges) == + applyChanges valAndChanges' where + + valAndChanges' = runTrans trans valAndChanges + +applyChanges :: Change p => (Value p, [p]) -> [Value p] +applyChanges (val, changes) = scanl (flip ($$)) val changes diff --git a/src/test-suites/TestSuite/Sequence.hs b/src/test-suites/TestSuite/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/test-suites/TestSuite/Sequence.hs @@ -0,0 +1,73 @@ +module TestSuite.Sequence ( + + tests + +) where + +-- Data + +import Data.Foldable (asum) +import Data.Incremental +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Incremental.Sequence as IncSeq + +-- Test + +import Test.QuickCheck +import Test.QuickCheck.Poly + +-- Distribution + +import Distribution.TestSuite + +-- TestSuite +import TestSuite + +-- * Tests + +tests :: IO [Test] +tests = return [transTest "singleton" IncSeq.singleton + (Seq.singleton :: A -> Seq A), + transTest "fromPair" IncSeq.fromPair + (seqFromPair :: (A, A) -> Seq A), + transTest "cat" IncSeq.cat + (seqCat :: (Seq A, Seq A) -> Seq A), + transTest "null" IncSeq.null + (Seq.null :: Seq A -> Bool), + transTest "length" IncSeq.length + (Seq.length :: Seq A -> Int), + transTest "map" (IncSeq.map testTrans) + (fmap (toFunction testTrans)), + transTest "map'" (IncSeq.map' testFun) + (fmap testFun), + transTest "concat" IncSeq.concat + (seqConcat :: Seq (Seq A) -> Seq A), + transTest "gate" (IncSeq.gate testPrdTrans) + (seqGate (toFunction testPrdTrans)), + transTest "gate'" (IncSeq.gate' testPrdFun) + (seqGate testPrdFun), + transTest "filter" (IncSeq.filter testPrdTrans) + (Seq.filter (toFunction testPrdTrans)), + transTest "filter'" (IncSeq.filter' testPrdFun) + (Seq.filter testPrdFun), + transTest "reverse" IncSeq.reverse + (Seq.reverse :: Seq A -> Seq A), + transTest "sort" IncSeq.sort + (Seq.sort :: Seq A -> Seq A), + transTest "sortBy" (IncSeq.sortBy testCompare) + (Seq.sortBy testCompare)] +-- FIXME: Explain why we have no test for concatMap. + +seqFromPair :: (a, a) -> Seq a +seqFromPair (val1, val2) = Seq.fromList [val1, val2] + +seqCat :: (Seq a, Seq a) -> Seq a +seqCat = uncurry (Seq.><) + +seqConcat :: Seq (Seq a) -> Seq a +seqConcat = asum + +seqGate :: (a -> Bool) -> a -> Seq a +seqGate prd val | prd val = Seq.singleton val + | otherwise = Seq.empty