packages feed

EdisonCore (empty) → 1.2.1

raw patch · 30 files changed

+13264/−0 lines, 30 filesdep +EdisonAPIdep +QuickCheckdep +basebuild-type:Customsetup-changed

Dependencies added: EdisonAPI, QuickCheck, base, haskell98, mtl

Files

@@ -0,0 +1,23 @@+Copyright (c) 1998-1999 Chris Okasaki+Portions Copyright (c) 2002 Andrew Bromage+Portions Copyright (c) 2006 Robert Dockins+Portions Copyright (c) 2006 David F. Place+Portions Copyright (c) 2006 Ross Paterson and Ralf Hinze++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ EdisonCore.cabal view
@@ -0,0 +1,55 @@+Name:           EdisonCore+Version:        1.2.1+License:        OtherLicense+License-File:   COPYRIGHT+Author:         Chris Okasaki+Maintainer:     robdockins AT fastmail DOT fm+Synopsis:       A library of efficient, purely-functional data structures (Core Implementations)+Category:       Data Structures+Stability:      stable+Description:+     This package provides the core Edison data structure implementations,+     including multiple sequence, set, bag, and finite map concrete+     implementations with various performance characteristics. The+     implementations in this package have no dependencies other than+     those commonly bundled with Haskell compilers.+Hs-Source-Dirs: src+Exposed-modules:+     Data.Edison.Assoc.Defaults+     Data.Edison.Assoc.AssocList+     Data.Edison.Assoc.PatriciaLoMap+     Data.Edison.Assoc.StandardMap+     Data.Edison.Assoc.TernaryTrie+     Data.Edison.Concrete.FingerTree+     Data.Edison.Coll.Defaults+     Data.Edison.Coll.LazyPairingHeap+     Data.Edison.Coll.LeftistHeap+     Data.Edison.Coll.MinHeap+     Data.Edison.Coll.SkewHeap+     Data.Edison.Coll.SplayHeap+     Data.Edison.Coll.StandardSet+     Data.Edison.Coll.EnumSet+     Data.Edison.Coll.UnbalancedSet+     Data.Edison.Seq.Defaults+     Data.Edison.Seq.BankersQueue+     Data.Edison.Seq.BinaryRandList+     Data.Edison.Seq.BraunSeq+     Data.Edison.Seq.FingerSeq+     Data.Edison.Seq.JoinList+     Data.Edison.Seq.MyersStack+     Data.Edison.Seq.RandList+     Data.Edison.Seq.RevSeq+     Data.Edison.Seq.SimpleQueue+     Data.Edison.Seq.SizedSeq+Build-Depends:+     base >= 1.0,+     haskell98 >= 1.0,+     mtl >= 1.0,+     QuickCheck == 1.0,+     EdisonAPI == 1.2.1+Extensions:+     MultiParamTypeClasses+     FunctionalDependencies+     UndecidableInstances+     CPP+Ghc-Options: -funbox-strict-fields -fwarn-incomplete-patterns -O2
+ README view
@@ -0,0 +1,206 @@+Edison: A Library of Efficient Data Structures+Version: 1.2.1+Dec 15, 2006+++About Edison+-----------------------++Edison is a library of purely function data structures for Haskell+originally written by Chris Okasaki.  Conceptually, it consists of two+things:+  1) A set of type classes defining data the following data structure+     abstractions: "sequences", "collections" and "associative collections"+  2) Multiple concrete implementations of each of the abstractions.++In theory, either component may be used independently of the other.++This release is an update to (hopefully) make Edison easier to use,+mostly by updating Edison to use the most current Haskell tools.+The following major changes have been made since version 1.1, which+was released in 1999.++  * Typeclasses updated to use fundeps (by Andrew Bromage)+  * Implementation of ternary search tries (by Andrew Bromage)+  * Modules renamed to use the hierarchical module extension+  * Documentation haddockized+  * Source moved to a darcs repository+  * Build system cabalized+  * Unit tests integrated into a single driver program which exercises+    all the concrete implementations shipped with Edison+  * Multiple additions to the APIs (mostly the associated collection API)+++Hopefully, these changes will make Edison more accessible than it has+been previously.+++License+-----------------------++Edison is released under an MIT style license.  See the COPYRIGHT+file for details.++++Building Edison+-----------------------++Edison is distributed as a set of related Cabal packages.+The EdisonAPI package contains the main API typeclass definitions.+The EdisonCore package provides the main concrete implementations;+this package depends on the EdisonAPI package.  The Edison-test+package contains the test suite and depends on both packages.++You may either manually invoke cabal for each of the sub-packages+as appropriate, or you may use the included Makefile, which will+build and install the EdisonAPI and EdisonCore packages+automaticly.++If you do not have an executable named 'runhaskell' on your search+path, you will need to edit the Makefile and set the RUNHS variable+appropriately (or run the cabal commands manually).++If you wish to build the API docs, you will first need to+build the relevant package and type the following command in+the package subdirectory:++runhaskell Setup.hs haddock+++A Note about Cabal versions+-----------------------------------++This version of edison builds correctly with Cabal version 1.1.4,+which is shipped with GHC 6.4.2.  To build on earlier versions,+it should suffice to:++s/UndecidableInstances/AllowUndecidableInstances/ +s/Hs-Source-Dirs:/Hs-Source-Dir:/++in the .cabal files.++++Notes on portability+----------------------++Short version:++Edison is expected to work correctly on recent GHC and Hugs (with+extensions enabled).  Other Haskell implementations may also work, but+have not been tested.+++Longer version:++Edison uses a number of extensions beyond Haskell 98, the current+official Haskell standard.  These include:++  * Multi-parameter typeclasses+  * Functional dependencies+  * Undecidable instances++In all cases, these extensions are used to allow the typeclass+abstractions to be expressed.  These extensions are fairly popular+and seem likely to make it in some form into a Haskell standard+(hopefully in the not too distant future).++Currently, Edison builds and runs correctly under GHC and Hugs.+More specificly, most development and testing has been done with+GHC 6.4.1, and the test suite builds and runs to completion with no errors.+With Hugs (March 2005 release) and the '-98' option, all of the core Edison+data structures should work correctly.  Unfortunately, the test suite will+not load, due to differences in Hugs' and GHC's implementations of +multi-parameter typeclasses.++As the extensions used are not recent developments, I also expect that less+recent versions of GHC and Hugs will also work.  Other implementations+may also work correctly with Edison, but this has not been tested.++++The Story on Edison Packages+----------------------------------++Cabal is a nice tool for building and distributing Haskell projects.  However,+it has the slightly undesirable property that the "Package" unit is the atomic+unit of compilation, documentation and of dependency resolution.  In order to+support implementations which have varying external dependencies, Edison has been+split into multiple cabal sub-packages, which cooperate.  The root package is+named 'EdisonAPI' and it contains the typeclass specifications, together with+extensive documentation and a few utility classes.  'EdisonAPI' essentially+represents a design contract.  The 'EdisonCore' package contains core Edison+implementations.  These implementations have no dependencies beyond the standard+libraries.  Other implementation modules are planned: these other modules+may have dependencies on eg, Adiran Hay's AVL tree implementation or Don+Stewart's Fast Packed String, etc.  Additionally there is a unit test package.+Currently it is tied to the 'EdisonCore' package, but in the future it will+provide basic unit testing capabilities for extended implementations as well.+++++Edison Versioning+-----------------------++As the maintainer of Edison, I take API stability very seriously.  My goal is+that programs written against Edison will not suffer from version drift.+However, I also wish to allow Edison to incorporate new ideas and evolve into a+better way to use data structures in Haskell.  In order to help accommodate these+somewhat opposing goals, I have adopted the following versioning scheme.  Respect+the versioning scheme, and you should have no compatibility problems.+++Each Edison release number is composed of four components:++  xxx.yyy.zzz.www+   ^   ^   ^   ^+   |   |   |   |+   |   |   |   +------ patch level+   |   |   +---------- API version number+   |   +-------------- minor version number+   +------------------ major version number+++The API version number and/or patch level may be omitted for brevity.  When+omitted, they are assumed to be 0.++I have adopted the (pre-2.6) Linux kernel versioning scheme for major and+minor numbers: the major number is incremented at major updates (ie, something+on the order of total API re-engineering or complete rewrites).  Minor numbers+represent "branches" of development.++Releases with even minor numbers are "stable" releases (0 is considered even).+For example, the Edison 1.2 release is a stable release. Even numbered releases+will have stable user-visible APIs; my goal is that any program compiled against+an Edison stable release will work correctly for all later Edison releases with+the same major and minor version numbers.  This means that API changes will be+limited to additions.  However, I intend that even additions be rare, and they will+only be considered with compelling evidence that the lack of the feature in question+inhibits desirable use cases.  The user-visible behavior of an implementation will+only be changed if it was originally in violation of the contract (ie, a bug).++*NOTE*+THE EXACT BEHAVIOR OF AMBIGUOUS OPERATIONS IS NOT CONSIDERED USER-VISIBLE BEHAVIOR,+nor is the behavior of unsafe operations when used in violation of their preconditions.+Ambiguous operations may change their behavior in stable releases as long as such+changes still obey the design contract.+++Releases with odd minor numbers are "development" branches.  Such releases+are branched from the immediately preceding stable release minor number.+For example, the Edison 1.3 development branch will be forked from the Edison 1.2+release family.  No guarantees are made about the user-visible APIs for development+branches.  API operations may be added, deleted, or have the terms of their design+contracts altered in development branches, and implementations may freely change their+behavior.  Eventually development branches are stabilized and transform into the next+even-numbered stable release.++For both even and odd minor numbers, the third component represents the "API version".+Any change to the API will cause a bump in the API version number.  For stable branches,+this should be fairly rare; for odd branches, it may occur rather frequently.++The fourth component is incremented for each official release whenever the first three+components are not altered.  Two Edison versions which differ only in their patch level+should have identical APIs.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ src/Data/Edison/Assoc/AssocList.hs view
@@ -0,0 +1,618 @@+-- |+--   Module      :  Data.Edison.Assoc.AssocList+--   Copyright   :  Copyright (c) 1998 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module implements finite maps as simple association lists.+--  +--   Duplicates are removed conceptually, but not physically.  The first+--   occurrence of a given key is the one that is considered to be in the map.+--+--   The list type is mildly customized to prevent boxing the pairs.++module Data.Edison.Assoc.AssocList (+    -- * Type of simple association lists+    FM, -- instance of Assoc(X), FiniteMap(X)+        -- also instance of Functor++    -- * AssocX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,++    -- * OrdAssocX operations+    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,+    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', +    foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend,+    filterLT, filterLE, filterGT, filterGE,+    partitionLT_GE, partitionLE_GT, partitionLT_GT,++    -- * Assoc operations+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,++    -- * OrdAssoc operations+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,++    -- * FiniteMapX operations+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,+    properSubmap,submap,sameMap,++    -- * FiniteMap operations+    unionWithKey,unionSeqWithKey,intersectionWithKey,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)+import qualified Prelude+import Data.Monoid+import Control.Monad.Identity+import Data.Edison.Prelude+import qualified Data.Edison.Assoc as A+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.BinaryRandList as RL+import Data.Edison.Assoc.Defaults+import Test.QuickCheck (Arbitrary(..), variant)++-- signatures for exported functions+moduleName    :: String+empty         :: Eq k => FM k a+singleton     :: Eq k => k -> a -> FM k a+fromSeq       :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a+insert        :: Eq k => k -> a -> FM k a -> FM k a+insertSeq     :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a+union         :: Eq k => FM k a -> FM k a -> FM k a+unionSeq      :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a+delete        :: Eq k => k -> FM k a -> FM k a+deleteAll     :: Eq k => k -> FM k a -> FM k a+deleteSeq     :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a+null          :: Eq k => FM k a -> Bool+size          :: Eq k => FM k a -> Int+member        :: Eq k => k -> FM k a -> Bool+count         :: Eq k => k -> FM k a -> Int+lookup        :: Eq k => k -> FM k a -> a+lookupM       :: (Eq k, Monad rm) => k -> FM k a -> rm a+lookupAll     :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a+lookupAndDelete    :: Eq k => k -> FM k a -> (a,FM k a)+lookupAndDeleteM   :: (Eq k,Monad rm)   => k -> FM k a -> rm (a,FM k a)+lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)+lookupWithDefault  :: Eq k => a -> k -> FM k a -> a+adjust             :: Eq k => (a -> a) -> k -> FM k a -> FM k a+adjustAll          :: Eq k => (a -> a) -> k -> FM k a -> FM k a+adjustOrInsert     :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a+adjustAllOrInsert  :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a+adjustOrDelete     :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a+adjustOrDeleteAll  :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a+strict             :: FM k a -> FM k a+strictWith         :: (a -> b) -> FM k a -> FM k a+map           :: Eq k => (a -> b) -> FM k a -> FM k b+fold          :: Eq k => (a -> b -> b) -> b -> FM k a -> b+fold1         :: Eq k => (a -> a -> a) -> FM k a -> a+fold'         :: Eq k => (a -> b -> b) -> b -> FM k a -> b+fold1'        :: Eq k => (a -> a -> a) -> FM k a -> a+filter        :: Eq k => (a -> Bool) -> FM k a -> FM k a+partition     :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a)+elements      :: (Eq k,S.Sequence seq) => FM k a -> seq a++fromSeqWith      :: (Eq k,S.Sequence seq) => +                        (a -> a -> a) -> seq (k,a) -> FM k a+fromSeqWithKey   :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a+insertWith       :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a+insertWithKey    :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a+insertSeqWith    :: (Eq k,S.Sequence seq) => +                        (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a+insertSeqWithKey :: (Eq k,S.Sequence seq) => +                        (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a+unionl           :: Eq k => FM k a -> FM k a -> FM k a+unionr           :: Eq k => FM k a -> FM k a -> FM k a+unionWith        :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWith     :: (Eq k,S.Sequence seq) => +                        (a -> a -> a) -> seq (FM k a) -> FM k a+intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c+difference       :: Eq k => FM k a -> FM k b -> FM k a+properSubset     :: Eq k => FM k a -> FM k b -> Bool    +subset           :: Eq k => FM k a -> FM k b -> Bool    +properSubmapBy   :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+submapBy         :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+sameMapBy        :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+properSubmap     :: (Eq k, Eq a) => FM k a -> FM k a -> Bool+submap           :: (Eq k, Eq a) => FM k a -> FM k a -> Bool+sameMap          :: (Eq k, Eq a) => FM k a -> FM k a -> Bool++toSeq            :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a)+keys             :: (Eq k,S.Sequence seq) => FM k a -> seq k+mapWithKey       :: Eq k => (k -> a -> b) -> FM k a -> FM k b+foldWithKey      :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b+foldWithKey'     :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b+filterWithKey    :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a+partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a)++unionWithKey     :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWithKey  :: (Eq k,S.Sequence seq) => +                        (k -> a -> a -> a) -> seq (FM k a) -> FM k a+intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c++minView          :: (Ord k,Monad m) => FM k a -> m (a,FM k a)+minElem          :: Ord k => FM k a -> a+deleteMin        :: Ord k => FM k a -> FM k a+unsafeInsertMin  :: Ord k => k -> a -> FM k a -> FM k a+maxView          :: (Ord k,Monad m) => FM k a -> m (a,FM k a)+maxElem          :: Ord k => FM k a -> a+deleteMax        :: Ord k => FM k a -> FM k a+unsafeInsertMax  :: Ord k => k -> a -> FM k a -> FM k a+foldr            :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldr1           :: Ord k => (a -> a -> a) -> FM k a -> a+foldl            :: Ord k => (b -> a -> b) -> b -> FM k a -> b+foldl1           :: Ord k => (a -> a -> a) -> FM k a -> a+foldr'           :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldr1'          :: Ord k => (a -> a -> a) -> FM k a -> a+foldl'           :: Ord k => (b -> a -> b) -> b -> FM k a -> b+foldl1'          :: Ord k => (a -> a -> a) -> FM k a -> a+unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a+unsafeAppend     :: Ord k => FM k a -> FM k a -> FM k a+filterLT         :: Ord k => k -> FM k a -> FM k a+filterLE         :: Ord k => k -> FM k a -> FM k a+filterGT         :: Ord k => k -> FM k a -> FM k a+filterGE         :: Ord k => k -> FM k a -> FM k a+partitionLT_GE   :: Ord k => k -> FM k a -> (FM k a,FM k a)+partitionLE_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)+partitionLT_GT   :: Ord k => k -> FM k a -> (FM k a,FM k a)++minViewWithKey    :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)+minElemWithKey    :: Ord k => FM k a -> (k,a)+maxViewWithKey    :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)+maxElemWithKey    :: Ord k => FM k a -> (k,a)+foldrWithKey      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b+foldlWithKey      :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b+foldrWithKey'     :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b+foldlWithKey'     :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b+toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)+++moduleName = "Data.Edison.Assoc.AssocList"+++data FM k a = E | I k a (FM k a)++-- no invariants+structuralInvariant :: Eq k => FM k a -> Bool+structuralInvariant = const True++---------------------------------------+-- some unexported utility functions++-- uncurried insert.+uinsert (k,x) = I k x+++-- left biased merge.+mergeFM E m = m+mergeFM m E = m+mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) =+  case compare k1 k2 of+      LT -> I k1 a1 (mergeFM m1 o2)+      GT -> I k2 a2 (mergeFM o1 m2)+      EQ -> I k1 a1 (mergeFM m1 m2)++toRandList E = RL.empty+toRandList (I k a m) = RL.lcons (I k a E) (toRandList m)++mergeSortFM m = RL.reducer mergeFM E (toRandList m)++foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b+foldrFM f z E = z+foldrFM f z (I k a m) = f a (foldrFM f z (delete k m))++foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a+foldr1FM f (I k a E) = a+foldr1FM f (I k a m) = f a (foldr1FM f (delete k m))+foldr1FM f _ = error "invalid call to foldr1FM on empty map"++foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b+foldrFM' f z E = z+foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m))++foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a+foldr1FM' f (I k a E) = a+foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m))+foldr1FM' f _ = error "invalid call to foldr1FM' on empty map"++foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b+foldlFM f x E = x+foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m)++foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b+foldlFM' f x E = x+foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m)++foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b+foldrWithKeyFM f z E = z+foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m))++foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b+foldrWithKeyFM' f z E = z+foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m))++foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b+foldlWithKeyFM f x E = x+foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m)++foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b+foldlWithKeyFM' f x E = x+foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m)++takeWhileFM :: (k -> Bool) -> FM k a -> FM k a+takeWhileFM p E = E+takeWhileFM p (I k a m)+   | p k       = I k a (takeWhileFM p m)+   | otherwise = E++dropWhileFM :: (k -> Bool) -> FM k a -> FM k a+dropWhileFM p E = E+dropWhileFM p o@(I k a m)+   | p k       = dropWhileFM p m+   | otherwise = o++spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a)+spanFM p E = (E,E)+spanFM p o@(I k a m)+   | p k       = let (x,y) = spanFM p m in (I k a x,y)+   | otherwise = (E,o)+++---------------------------------------------------+-- interface functions++empty = E+singleton k x = I k x E+insert = I+insertSeq kxs m = S.foldr uinsert m kxs+fromSeq = S.foldr uinsert E++union m E = m+union E m = m+union (I k x m1) m2 = I k x (union m1 m2)++unionSeq = S.foldr union E++deleteAll key E = E+deleteAll key (I k x m) | key == k  = deleteAll key m +                        | otherwise = I k x (deleteAll key m)++delete = deleteAll++null E = True+null (I k x m) = False++size E = 0+size (I k x m) = 1 + size (delete k m)++member key E = False+member key (I k x m) = key == k || member key m++count key E = 0+count key (I k x m) | key == k  = 1+                    | otherwise = count key m++lookup key m = runIdentity (lookupM key m)++lookupM key E = fail "AssocList.lookup: lookup failed"+lookupM key (I k x m) | key == k  = return x+                      | otherwise = lookupM key m++lookupAll key E = S.empty+lookupAll key (I k x m) | key == k  = S.singleton x +                        | otherwise = lookupAll key m++lookupAndDelete key m = runIdentity (lookupAndDeleteM key m)++lookupAndDeleteM key E = fail "AssocList.lookupAndDeleteM: lookup failed"+lookupAndDeleteM key (I k x m)+   | key == k  = return (x,delete k m)+   | otherwise = lookupAndDeleteM key m >>= +                    \ (z, m') -> return (z, I k x m')++lookupAndDeleteAll key m = +   case lookupAndDeleteM key m of+      Nothing     -> (S.empty,m)+      Just (z,m') -> (S.singleton z,m')+++lookupWithDefault d key E = d+lookupWithDefault d key (I k x m) | key == k = x+                                  | otherwise = lookupWithDefault d key m++elements E = S.empty+elements (I k x m) = S.lcons x (elements (delete k m))++adjust f key E = E+adjust f key (I k x m) | key == k  = I key (f x) m+                       | otherwise = I k x (adjust f key m)++adjustAll = adjust++adjustOrInsert f z key E = singleton key z+adjustOrInsert f z key (I k x m)+    | key == k  = I key (f x) m+    | otherwise = I k x (adjustOrInsert f z key m)++adjustAllOrInsert = adjustOrInsert++adjustOrDelete = adjustOrDeleteDefault+adjustOrDeleteAll = adjustOrDeleteAllDefault++map f E = E+map f (I k x m) = I k (f x) (map f m)++fold f c E = c+fold f c (I k x m) = fold f (f x c) (delete k m)++fold' f c E = c+fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m)++fold1 f E = error "AssocList.fold1: empty map"+fold1 f (I k x m) = fold f x (delete k m)++fold1' f E = error "AssocList.fold1': empty map"+fold1' f (I k x m) = fold' f x (delete k m)++filter p E = E+filter p (I k x m) | p x = I k x (filter p (delete k m))+                   | otherwise = filter p (delete k m)++partition p E = (E, E)+partition p (I k x m)+    | p x       = (I k x m1,m2)+    | otherwise = (m1,I k x m2)+  where (m1,m2) = partition p (delete k m)+++toSeq E = S.empty+toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m))++keys E = S.empty+keys (I k x m) = S.lcons k (keys (delete k m))++mapWithKey f E = E+mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m)++foldWithKey f c E = c+foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m)++foldWithKey' f c E = c+foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m)++filterWithKey p E = E+filterWithKey p (I k x m) +    | p k x = I k x (filterWithKey p (delete k m))+    | otherwise = filterWithKey p (delete k m)++partitionWithKey p E = (E, E)+partitionWithKey p (I k x m)+    | p k x     = (I k x m1,m2)+    | otherwise = (m1,I k x m2)+  where (m1,m2) = partitionWithKey p (delete k m)++unionl = union+unionr = flip union+++findMin k0 x E = (k0,x)+findMin k0 a0 (I k a m)+        | k < k0    = findMin k  a  (delete k m)+        | otherwise = findMin k0 a0 (delete k m)++findMax k0 x E = (k0,x)+findMax k0 a0 (I k a m)+        | k > k0    = findMax k  a  (delete k m)+        | otherwise = findMax k0 a0 (delete k m)++minView E = fail (moduleName++".minView: empty map")+minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n)++minElem E = error (moduleName++".minElem: empty map")+minElem (I k a m) = let (_,x) = findMin k a m in x++deleteMin E = error (moduleName++".deleteMin: empty map")+deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n++unsafeInsertMin  = insert++maxView E = fail (moduleName++".maxView: empty map")+maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n)++maxElem E = error (moduleName++".maxElem: empty map")+maxElem (I k a m) = let (_,x) = findMax k a m in x++deleteMax E = error (moduleName++".deleteMax: empty map")+deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n++unsafeInsertMax = insert++foldr  f z m = foldrFM  f z (mergeSortFM m)+foldr' f z m = foldrFM' f z (mergeSortFM m)++foldr1 f m =+  case mergeSortFM m of+    E -> error $ moduleName++".foldlr1: empty map"+    m -> foldr1FM f m++foldr1' f m =+  case mergeSortFM m of+    E -> error $ moduleName++".foldlr1': empty map"+    m -> foldr1FM' f m+   +foldl  f x m = foldlFM  f x (mergeSortFM m)+foldl' f x m = foldlFM' f x (mergeSortFM m)++foldl1 f m =+  case mergeSortFM m of+    E -> error $ moduleName++".foldl1: empty map"+    I k a m -> foldlFM f a (delete k m)++foldl1' f m =+  case mergeSortFM m of+    E -> error $ moduleName++".foldl1': empty map"+    I k a m -> foldlFM' f a (delete k m)++unsafeFromOrdSeq   = fromSeq+unsafeAppend       = union+filterLT k         = takeWhileFM (<k)  . mergeSortFM+filterLE k         = takeWhileFM (<=k) . mergeSortFM+filterGT k         = dropWhileFM (<=k) . mergeSortFM+filterGE k         = dropWhileFM (<k)  . mergeSortFM+partitionLT_GE k   = spanFM (<k)  . mergeSortFM+partitionLE_GT k   = spanFM (<=k) . mergeSortFM+partitionLT_GT k   = (\(x,y) -> (x,delete k y)) . spanFM (<k)  . mergeSortFM++minViewWithKey E   = fail $ moduleName++".minViewWithKey: empty map"+minViewWithKey n@(I k a m) = let (k',x) = findMin k a m in return ((k',x),delete k' n)++minElemWithKey E   = error $ moduleName++".minElemWithKey: empty map"+minElemWithKey (I k a m) = findMin k a m++maxViewWithKey E   = fail $ moduleName++".maxViewWithKey: empty map"+maxViewWithKey n@(I k a m) = let (k',x) = findMax k a m in return ((k',x),delete k' n)++maxElemWithKey E   = error $ moduleName++".maxElemWithKey: empty map"+maxElemWithKey (I k a m) = findMax k a m++foldrWithKey  f z   = foldrWithKeyFM  f z . mergeSortFM+foldrWithKey' f z   = foldrWithKeyFM' f z . mergeSortFM+foldlWithKey  f x   = foldlWithKeyFM  f x . mergeSortFM+foldlWithKey' f x   = foldlWithKeyFM' f x . mergeSortFM+toOrdSeq            = toSeq . mergeSortFM+++strict n@E = n+strict n@(I k a m) = strict m `seq` n++strictWith f n@E = n+strictWith f n@(I k a m) = f a `seq` strictWith f m `seq` n+++-- defaults++deleteSeq = deleteSeqUsingFoldr+insertWith = insertWithUsingLookupM+insertSeqWith = insertSeqWithUsingInsertWith+insertWithKey = insertWithKeyUsingInsertWith+insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey+unionWith = unionWithUsingInsertWith+unionSeqWith = unionSeqWithUsingFoldr+fromSeqWith = fromSeqWithUsingInsertSeqWith+fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey+intersectionWith = intersectionWithUsingLookupM+difference = differenceUsingDelete+properSubset = properSubsetUsingSubset+subset = subsetUsingMember+properSubmapBy = properSubmapByUsingSubmapBy+submapBy = submapByUsingLookupM+sameMapBy = sameMapByUsingSubmapBy+properSubmap = A.properSubmap+submap = A.submap+sameMap = A.sameMap+unionWithKey = unionWithKeyUsingInsertWithKey+unionSeqWithKey = unionSeqWithKeyUsingFoldr+intersectionWithKey = intersectionWithKeyUsingLookupM++-- instance declarations++instance Eq k  => A.AssocX (FM k) k where+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; +   insertSeq = insertSeq; union = union; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; +   null = null; size = size; member = member; count = count; +   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; +   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;+   lookupAndDeleteAll = lookupAndDeleteAll;+   lookupWithDefault = lookupWithDefault; adjust = adjust; +   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;+   adjustAllOrInsert = adjustAllOrInsert;+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; elements = elements;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName m = moduleName}++instance Ord k => A.OrdAssocX (FM k) k where+  {minView = minView; minElem = minElem; deleteMin = deleteMin;+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Eq k => A.FiniteMapX (FM k) k where+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; +   insertWith  = insertWith; insertWithKey = insertWithKey; +   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; +   unionl = unionl; unionr = unionr; unionWith = unionWith; +   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; +   difference = difference; properSubset = properSubset; subset = subset;+   properSubmapBy = properSubmapBy; submapBy = submapBy;+   sameMapBy = sameMapBy}++instance Ord k => A.OrdFiniteMapX (FM k) k++instance Eq k  => A.Assoc (FM k) k where+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; +   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';+   filterWithKey = filterWithKey; +   partitionWithKey = partitionWithKey}++instance Ord k => A.OrdAssoc (FM k) k where+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';+   toOrdSeq = toOrdSeq}++instance Eq k => A.FiniteMap (FM k) k where+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; +   intersectionWithKey = intersectionWithKey}++instance Ord k => A.OrdFiniteMap (FM k) k++instance Eq k => Functor (FM k) where+  fmap =  map++instance (Eq k,Eq a) => Eq (FM k a) where+  (==) = sameMap++instance (Ord k, Ord a) => Ord (FM k a) where+  compare = compareUsingToOrdList++instance (Eq k,Show k,Show a) => Show (FM k a) where+  showsPrec = showsPrecUsingToList++instance (Eq k,Read k,Read a) => Read (FM k a) where+  readsPrec = readsPrecUsingFromList++instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where+   arbitrary = do xs <- arbitrary+                  return (Prelude.foldr (uncurry insert) empty xs)++   coarbitrary E = variant 0+   coarbitrary (I k a m) = variant 1 . coarbitrary k+                         . coarbitrary a . coarbitrary m+++instance Eq k => Monoid (FM k a) where+   mempty  = empty+   mappend = union+   mconcat = unionSeq
+ src/Data/Edison/Assoc/Defaults.hs view
@@ -0,0 +1,313 @@+-- |+--   Module      :  Data.Edison.Assoc.Defaults+--   Copyright   :  Copyright (c) 1998 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  internal (unstable)+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module provides default implementations of many of the associative+--   collection operations.  These function are used to fill in collection+--   implementations and are not intended to be used directly by end users.++module Data.Edison.Assoc.Defaults where++import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)+import Data.Maybe (fromJust)++import Data.Edison.Assoc+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)++singletonUsingInsert :: (Assoc m k) => k -> a -> m a+singletonUsingInsert k v = insert k v empty++fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a+fromSeqUsingInsertSeq kvs = insertSeq kvs empty++insertSeqUsingFoldr :: +    (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a+insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs++unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a+unionSeqUsingReduce ms = S.reducel union empty ms++deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a+deleteSeqUsingFoldr ks m = S.foldr delete m ks++memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool+memberUsingLookupM k m+  = case lookupM k m of+  	Just _  -> True+	Nothing -> False++sizeUsingElements :: (AssocX m k) => m a -> Int+sizeUsingElements m = length (elements m)++countUsingMember :: AssocX m k => k -> m a -> Int+countUsingMember k m = if member k m then 1 else 0++lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a+lookupAllUsingLookupM k m = case lookupM k m of+                              Just x -> S.singleton x+                              Nothing -> S.empty++lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a+lookupWithDefaultUsingLookupM d k m = case lookupM k m of+                                        Just x -> x+                                        Nothing -> d++partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a)+partitionUsingFilter f m = (filter f m, filter (not . f) m)++fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a+fold1UsingElements op m = L.foldr1 op (elements m)++elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a+elementsUsingFold = fold S.lcons S.empty++nullUsingElements :: (AssocX m k) => m a -> Bool+nullUsingElements m+  = case elements m of+  	[] -> True+  	_  -> False++insertWithUsingLookupM :: +    FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a+insertWithUsingLookupM f k x m =+    case lookupM k m of+      Nothing -> insert k x m+      Just y  -> insert k (f x y) m++fromSeqWithUsingInsertSeqWith ::+    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a+fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty++fromSeqWithKeyUsingInsertSeqWithKey :: +    (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a+fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty++insertWithKeyUsingInsertWith :: +    FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a+insertWithKeyUsingInsertWith f k = insertWith (f k) k++insertSeqWithUsingInsertWith :: +    (FiniteMapX m k,S.Sequence seq) => +      (a -> a -> a) -> seq (k,a) -> m a -> m a+insertSeqWithUsingInsertWith f kvs m =+    S.foldr (uncurry (insertWith f)) m kvs++insertSeqWithKeyUsingInsertWithKey ::+    (FiniteMapX m k,S.Sequence seq) => +      (k -> a -> a -> a) -> seq (k,a) -> m a -> m a+insertSeqWithKeyUsingInsertWithKey f kvs m =+    S.foldr (uncurry (insertWithKey f)) m kvs++unionSeqWithUsingReduce :: +    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a+unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms++unionSeqWithUsingFoldr :: +    (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a+unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms++toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a)+toSeqUsingFoldWithKey = foldWithKey conspair S.empty+  where conspair k v kvs = S.lcons (k,v) kvs++keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k+keysUsingFoldWithKey = foldWithKey conskey S.empty+  where conskey k v ks = S.lcons k ks++unionWithUsingInsertWith :: +    FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a+unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1++unionWithKeyUsingInsertWithKey :: +    FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a+unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1++unionSeqWithKeyUsingReduce :: +    (FiniteMap m k,S.Sequence seq) => +      (k -> a -> a -> a) -> seq (m a) -> m a+unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms++unionSeqWithKeyUsingFoldr :: +    (FiniteMap m k,S.Sequence seq) => +      (k -> a -> a -> a) -> seq (m a) -> m a+unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms++intersectionWithUsingLookupM :: +    FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c+intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1+  where ins k x m = case lookupM k m2 of+                      Nothing -> m+                      Just y  -> insert k (f x y) m++intersectionWithKeyUsingLookupM :: +    FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c+intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1+  where ins k x m = case lookupM k m2 of+                      Nothing -> m+                      Just y  -> insert k (f k x y) m++differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a+differenceUsingDelete m1 m2 = foldWithKey del m1 m2+  where del k _ m = delete k m++properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool+properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2++subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool+subsetUsingMember m1 m2 = foldWithKey mem True m1+  where mem k _ b = member k m2 && b++submapByUsingLookupM :: FiniteMap m k +                     => (a -> a -> Bool) -> m a -> m a -> Bool+submapByUsingLookupM  f m1 m2 = foldWithKey aux True m1+  where aux k x b =+          case lookupM k m2 of+             Nothing -> False+             Just y  -> f x y && b++properSubmapByUsingSubmapBy :: FiniteMapX m k +                            => (a -> a -> Bool) -> m a -> m a -> Bool+properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2++sameMapByUsingOrdLists :: OrdFiniteMap m k+                       => (a -> a -> Bool) -> m a -> m a -> Bool+sameMapByUsingOrdLists f m1 m2 =+   let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2+   in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2))+++sameMapByUsingSubmapBy :: FiniteMapX m k+                       => (a -> a -> Bool) -> m a -> m a -> Bool+sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2+++lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a)+lookupAndDeleteDefault k m =+  case lookupM k m of+     Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed")+     Just x  -> (x, delete k m)++lookupAndDeleteMDefault :: (Monad rm, AssocX m k) => k -> m a -> rm (a, m a)+lookupAndDeleteMDefault k m =+  case lookupM k m of+     Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed")+     Just x  -> return (x, delete k m)++lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a)+lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m)++adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a+adjustOrInsertUsingMember f z k m =+  if member k m+     then adjust f k m+     else insert k z m++adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a+adjustOrDeleteDefault f k m =+  case lookupAndDeleteM k m of+    Nothing -> m+    Just (elem,m') ->+      case f elem of+         Nothing -> m'+         Just x  -> insert k x m'++adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a+adjustOrDeleteAllDefault f k m =+  let (elems,m') = lookupAndDeleteAll k m+      adjSeq = S.map f elems+      ins Nothing  m = m+      ins (Just x) m = insert k x m+  in L.foldr ins m' adjSeq++minElemUsingMinView :: OrdAssocX m k => m a -> a+minElemUsingMinView fm =+  case minView fm of+     Nothing    -> error $ (instanceName fm)++".minElem: empty map"+     Just (x,_) -> x++deleteMinUsingMinView :: OrdAssocX m k => m a -> m a+deleteMinUsingMinView fm =+  case minView fm of+     Nothing    -> error $ (instanceName fm)++".deleteMin: empty map"+     Just (_,m) -> m++minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a)+minElemWithKeyUsingMinViewWithKey fm =+  case minViewWithKey fm of+     Nothing    -> error $ (instanceName fm)++".minElemWithKey: empty map"+     Just (x,_) -> x++maxElemUsingMaxView :: OrdAssocX m k => m a -> a+maxElemUsingMaxView fm =+  case maxView fm of+     Nothing    -> error $ (instanceName fm)++".maxElem: empty map"+     Just (x,_) -> x++deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a+deleteMaxUsingMaxView fm =+  case maxView fm of+     Nothing    -> error $ (instanceName fm)++".deleteMax: empty map"+     Just (_,m) -> m++maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a)+maxElemWithKeyUsingMaxViewWithKey fm =+  case maxViewWithKey fm of+     Nothing    -> error $ (instanceName fm)++".maxElemWithKey: empty map"+     Just (x,_) -> x++toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a)+toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty++showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS+showsPrecUsingToList i xs rest+   | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]+   | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]++readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a)+readsPrecUsingFromList i xs =+   let result = maybeParens p xs+       p xs = tokenMatch ((instanceName x)++".fromSeq") xs+                >>= readsPrec 10+                >>= \(l,rest) -> return (fromList l,rest)++       -- play games with the typechecker so we don't have to use+       -- extensions for scoped type variables+       ~[(x,_)] = result++   in result++showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS+showsPrecUsingToOrdList i xs rest+   | i == 0    = concat [    instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest]+   | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)]++readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a)+readsPrecUsingUnsafeFromOrdSeq i xs =+   let result = maybeParens p xs+       p xs = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") xs+                >>= readsPrec i+                >>= \(l,rest) -> return (unsafeFromOrdList l,rest)++       -- play games with the typechecker so we don't have to use+       -- extensions for scoped type variables+       ~[(x,_)] = result++   in result++compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering+compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)+ where+  cmp [] [] = EQ+  cmp [] _  = LT+  cmp _  [] = GT+  cmp (x:xs) (y:ys) =+      case compare x y of+         EQ -> cmp xs ys+         c -> c
+ src/Data/Edison/Assoc/PatriciaLoMap.hs view
@@ -0,0 +1,838 @@+-- |+--   Module      :  Data.Edison.Assoc.PatriciaLoMap+--   Copyright   :  Copyright (c) 1998 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Finite maps implemented as little-endian Patricia trees.+--+--   /References:/+--+-- * Chris Okasaki and Any Gill.  \"Fast Mergeable Integer Maps\".+--   Workshop on ML, September 1998, pages 77-86.++module Data.Edison.Assoc.PatriciaLoMap (+    -- * Type of little-endian Patricia trees+    FM,++    -- * AssocX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith,+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map,+    fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,++    -- * Assoc operations+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,++    -- * FiniteMapX operations+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,+    properSubmap,submap,sameMap,++    -- * FiniteMap operations+    unionWithKey,unionSeqWithKey,intersectionWithKey,++    -- * OrdAssocX operations+    minView, minElem, deleteMin, unsafeInsertMin,+    maxView, maxElem, deleteMax, unsafeInsertMax,+    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',+    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,+    partitionLT_GE, partitionLE_GT, partitionLT_GT,++    -- * OrdAssoc operations+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',+    toOrdSeq,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)+import qualified Prelude+import Control.Monad.Identity (runIdentity)+import Data.Monoid+import Data.Edison.Prelude+import qualified Data.Edison.Assoc as A+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Assoc.Defaults+import Data.Int+import Data.Bits+import Test.QuickCheck (Arbitrary(..), variant)++moduleName = "Data.Edison.Assoc.PatriciaLoMap"++data FM a+  = E+  | L Int a+  | B Int Int !(FM a) !(FM a)++-- Invariants:+-- * No B node has an E child+-- * first argument to B is a prefix+-- * second argument to B is the "branching bit" and is+--   always an exact power of two+-- * all bits in the prefix >= the branching bit are zeros+-- * valid prefix bits match all subnodes++structuralInvariant :: FM a -> Bool+structuralInvariant E = True+structuralInvariant (L k x) = True+structuralInvariant x = inv 0 0 x++inv :: Int -> Int -> FM a -> Bool+inv pre msk E = False+inv pre msk (L k x) = k .&. msk == pre+inv pre msk (B p m t0 t1) =+    (p .&. msk == pre) &&+    (bitcount 0 m == 1) &&+    (p .&. (complement (m - 1)) == 0) &&+    inv p0 msk' t0 &&+    inv p1 msk' t1++  where p0 = p+        p1 = p .|. m+        msk' = (m `shiftL` 1) - 1++bitcount :: Int -> Int -> Int+bitcount a 0 = a+bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))++-- auxiliary functions++makeB p m E t = t+makeB p m t E = t+makeB p m t0 t1 = B p m t0 t1++lmakeB p m E t = t+lmakeB p m t0 t1 = B p m t0 t1++rmakeB p m t E = t+rmakeB p m t0 t1 = B p m t0 t1++lowestBit :: Int32 -> Int32+lowestBit x = x .&. (-x)++branchingBit :: Int -> Int -> Int+branchingBit p0 p1 = +  fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1))++mask :: Int -> Int -> Int+mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Int32)))++zeroBit :: Int -> Int -> Bool+zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Int32)++matchPrefix :: Int -> Int -> Int -> Bool+matchPrefix k p m = mask k m == p++join p0 t0 p1 t1 =+  let m = branchingBit p0 p1+  in if zeroBit p0 m then B (mask p0 m) m t0 t1+                     else B (mask p0 m) m t1 t0++keepR x y = y++-- end auxiliary functions++empty :: FM a+empty = E++singleton :: Int -> a -> FM a+singleton k x = L k x++fromSeq :: S.Sequence seq => seq (Int,a) -> FM a+fromSeq = S.foldl (\t (k, x) -> insert k x t) E++insert :: Int -> a -> FM a -> FM a+insert k x E = L k x+insert k x t@(L j y) = if j == k then L k x else join k (L k x) j t+insert k x t@(B p m t0 t1) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insert k x t0) t1+                     else B p m t0 (insert k x t1)+    else join k (L k x) p t++union :: FM a -> FM a -> FM a+union s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then B p m (union s0 t) s1+                                 else B p m s0 (union s1 t)+                else join p s q t+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then B q n (union s t0) t1+                                 else B q n t0 (union s t1)+                else join p s q t+  | otherwise = if p == q then B p m (union s0 t0) (union s1 t1)+                else join p s q t+union s@(B p m s0 s1) (L k x) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insert k x s0) s1+                     else B p m s0 (insert k x s1)+    else join k (L k x) p s+union s@(B _ _ _ _) E = s+union (L k x) t = insert k x t+union E t = t++delete :: Int -> FM a -> FM a+delete k E = E+delete k t@(L j x) = if k == j then E else t+delete k t@(B p m t0 t1) =+    if matchPrefix k p m then+      if zeroBit k m then lmakeB p m (delete k t0) t1+                     else rmakeB p m t0 (delete k t1)+    else t++null :: FM a -> Bool+null E = True+null _ = False++size :: FM a -> Int+size E = 0+size (L _ _) = 1+size (B _ _ t0 t1) = size t0 + size t1++member :: Int -> FM a -> Bool+member k E = False+member k (L j x) = (j == k)+member k (B p m t0 t1) = if zeroBit k m then member k t0 else member k t1++lookup :: Int -> FM a -> a+lookup k m = runIdentity (lookupM k m)++lookupM :: (Monad rm) => Int -> FM a -> rm a+lookupM k E = fail "PatriciaLoMap.lookup: lookup failed"+lookupM k (L j x)+  | j == k    = return x+  | otherwise = fail "PatriciaLoMap.lookup: lookup failed"+lookupM k (B p m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1++doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z+doLookupAndDelete onFail cont k E = onFail+doLookupAndDelete onFail cont k (L j x)+     | j == k    = cont x E+     | otherwise = onFail+doLookupAndDelete onFail cont k (B p m t0 t1)+     | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0+     | otherwise   = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1++lookupAndDelete :: Int -> FM a -> (a, FM a)+lookupAndDelete        = doLookupAndDelete +                           (error "PatriciaLoMap.lookupAndDelete: lookup failed") +                           (,)++lookupAndDeleteM :: Monad m => Int -> FM a -> m (a, FM a)+lookupAndDeleteM       = doLookupAndDelete +                           (fail "PatriciaLoMap.lookupAndDelete: lookup failed")+                           (\x m -> return (x,m))++lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a)+lookupAndDeleteAll k m = doLookupAndDelete+                           (S.empty, m)+                           (\x m' -> (S.singleton x,m'))+                           k m+++adjust :: (a -> a) -> Int -> FM a -> FM a+adjust f k E = E+adjust f k t@(L j x) = if k == j then L k (f x) else t+adjust f k t@(B p m t0 t1) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (adjust f k t0) t1+                     else B p m t0 (adjust f k t1)+    else t++-- FIXME can we do better than this?+adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a+adjustOrInsert = adjustOrInsertUsingMember++adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a+adjustAllOrInsert = adjustOrInsertUsingMember++adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a+adjustOrDelete = adjustOrDeleteDefault++adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a+adjustOrDeleteAll = adjustOrDeleteDefault++map :: (a -> b) -> FM a -> FM b+map f E = E+map f (L k x) = L k (f x)+map f (B p m t0 t1) = B p m (map f t0) (map f t1)++fold :: (a -> b -> b) -> b -> FM a -> b+fold f c E = c+fold f c (L k x) = f x c+fold f c (B p m t0 t1) = fold f (fold f c t1) t0++fold' :: (a -> b -> b) -> b -> FM a -> b+fold' f c E = c+fold' f c (L k x) = c `seq` f x c+fold' f c (B p m t0 t1) = c `seq` (fold f $! (fold f c t1)) t0++fold1 :: (a -> a -> a) -> FM a -> a+fold1 f E = error "PatriciaLoMap.fold1: empty map"+fold1 f (L k x) = x+fold1 f (B p m t0 t1) = f (fold1 f t0) (fold1 f t1)++fold1' :: (a -> a -> a) -> FM a -> a+fold1' f E = error "PatriciaLoMap.fold1: empty map"+fold1' f (L k x) = x+fold1' f (B p m t0 t1) = f (fold1' f t0) $! (fold1' f t1)++filter :: (a -> Bool) -> FM a -> FM a+filter g E = E+filter g t@(L k x) = if g x then t else E+filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1)++partition :: (a -> Bool) -> FM a -> (FM a, FM a)+partition g E = (E, E)+partition g t@(L k x) = if g x then (t, E) else (E, t)+partition g (B p m t0 t1) =+  let (t0',t0'') = partition g t0+      (t1',t1'') = partition g t1+  in (makeB p m t0' t1', makeB p m t0'' t1'')+  +fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a+fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E++insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a+insertWith f k x E = L k x+insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t+insertWith f k x t@(B p m t0 t1) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insertWith f k x t0) t1+                     else B p m t0 (insertWith f k x t1)+    else join k (L k x) p t++unionl :: FM a -> FM a -> FM a+unionl s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then B p m (unionl s0 t) s1+                                 else B p m s0 (unionl s1 t)+                else join p s q t+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then B q n (unionl s t0) t1+                                 else B q n t0 (unionl s t1)+                else join p s q t+  | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1)+                else join p s q t+unionl s@(B p m s0 s1) (L k x) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insertWith keepR k x s0) s1+                     else B p m s0 (insertWith keepR k x s1)+    else join k (L k x) p s+unionl s@(B _ _ _ _) E = s+unionl (L k x) t = insert k x t+unionl E t = t++unionr :: FM a -> FM a -> FM a+unionr s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then B p m (unionr s0 t) s1+                                 else B p m s0 (unionr s1 t)+                else join p s q t+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then B q n (unionr s t0) t1+                                 else B q n t0 (unionr s t1)+                else join p s q t+  | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1)+                else join p s q t+unionr s@(B p m s0 s1) (L k x) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insert k x s0) s1+                     else B p m s0 (insert k x s1)+    else join k (L k x) p s+unionr s@(B _ _ _ _) E = s+unionr (L k x) t = insertWith keepR k x t+unionr E t = t++unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a+unionWith f s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then B p m (unionWith f s0 t) s1+                                 else B p m s0 (unionWith f s1 t)+                else join p s q t+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then B q n (unionWith f s t0) t1+                                 else B q n t0 (unionWith f s t1)+                else join p s q t+  | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1)+                else join p s q t+unionWith f s@(B p m s0 s1) (L k x) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insertWith (flip f) k x s0) s1+                     else B p m s0 (insertWith (flip f) k x s1)+    else join k (L k x) p s+unionWith f s@(B _ _ _ _) E = s+unionWith f (L k x) t = insertWith f k x t+unionWith f E t = t++intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c+intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then intersectionWith f s0 t+                                 else intersectionWith f s1 t+                else E+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then intersectionWith f s t0+                                 else intersectionWith f s t1+                else E+  | otherwise = if p /= q then E+                else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1)+intersectionWith f (B p m s0 s1) (L k y) =+    case lookupM k (if zeroBit k m then s0 else s1) of+      Just x  -> L k (f x y)+      Nothing -> E+intersectionWith f s@(B _ _ _ _) E = E+intersectionWith f (L k x) t =+    case lookupM k t of+      Just y  -> L k (f x y)+      Nothing -> E+intersectionWith f E t = E++difference :: FM a -> FM b -> FM a+difference s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then lmakeB p m (difference s0 t) s1+                                 else rmakeB p m s0 (difference s1 t)+                else s+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then difference s t0+                                 else difference s t1+                else s+  | otherwise = if p /= q then s+                else makeB p m (difference s0 t0) (difference s1 t1)+difference s@(B p m s0 s1) (L k y) =+    if matchPrefix k p m then+      if zeroBit k m then lmakeB p m (delete k s0) s1+                     else rmakeB p m s0 (delete k s1)+    else s+difference s@(B _ _ _ _) E = s+difference s@(L k x) t = if member k t then E else s+difference E t = E++properSubset :: FM a -> FM b -> Bool+properSubset s t = case subset' s t of {LT -> True; _ -> False}++subset' s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = GT+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then subset' s t0+                                 else subset' s t1+                else GT+  | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of+                                  (GT,_)  -> GT+                                  (_,GT)  -> GT+                                  (EQ,EQ) -> EQ+                                  (_,_)   -> LT+                else GT+subset' (B p m s0 s1) _ = GT+subset' (L k x) (L j y) = if k == j then EQ else GT+subset' (L k x) t = if member k t then LT else GT+subset' E E = EQ+subset' E _ = LT++subset :: FM a -> FM b -> Bool+subset s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = False+  | m > n    = matchPrefix p q n && (if zeroBit p n then subset s t0+                                                     else subset s t1)+  | otherwise = (p == q) && subset s0 t0 && subset s1 t1+subset (B p m s0 s1) _ = False+subset (L k x) t = member k t+subset E t = True++properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool+properSubmapBy = properSubmapByUsingSubmapBy++submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool+submapBy = submapByUsingLookupM++sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool+sameMapBy = sameMapByUsingSubmapBy++properSubmap :: (Eq a) => FM a -> FM a -> Bool+properSubmap = A.properSubmap++submap :: (Eq a) => FM a -> FM a -> Bool+submap = A.submap++sameMap :: (Eq a) => FM a -> FM a -> Bool+sameMap = A.sameMap++mapWithKey :: (Int -> a -> b) -> FM a -> FM b+mapWithKey f E = E+mapWithKey f (L k x) = L k (f k x)+mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1)++foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b+foldWithKey f c E = c+foldWithKey f c (L k x) = f k x c+foldWithKey f c (B p m t0 t1) = foldWithKey f (foldWithKey f c t1) t0++foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b+foldWithKey' f c E = c+foldWithKey' f c (L k x) = c `seq` f k x c+foldWithKey' f c (B p m t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0+++filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a+filterWithKey g E = E+filterWithKey g t@(L k x) = if g k x then t else E+filterWithKey g (B p m t0 t1) = +  makeB p m (filterWithKey g t0) (filterWithKey g t1)++partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a)+partitionWithKey g E = (E, E)+partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t)+partitionWithKey g (B p m t0 t1) =+  let (t0',t0'') = partitionWithKey g t0+      (t1',t1'') = partitionWithKey g t1+  in (makeB p m t0' t1', makeB p m t0'' t1'')++unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a+unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then B p m (unionWithKey f s0 t) s1+                                 else B p m s0 (unionWithKey f s1 t)+                else join p s q t+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then B q n (unionWithKey f s t0) t1+                                 else B q n t0 (unionWithKey f s t1)+                else join p s q t+  | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1)+                else join p s q t+unionWithKey f s@(B p m s0 s1) (L k x) =+    if matchPrefix k p m then+      if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1+                     else B p m s0 (insertWith (flip (f k)) k x s1)+    else join k (L k x) p s+unionWithKey f s@(B _ _ _ _) E = s+unionWithKey f (L k x) t = insertWith (f k) k x t+unionWithKey f E t = t++intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c+intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)+  | m < n    = if matchPrefix q p m then+                  if zeroBit q m then intersectionWithKey f s0 t+                                 else intersectionWithKey f s1 t+                else E+  | m > n    = if matchPrefix p q n then+                  if zeroBit p n then intersectionWithKey f s t0+                                 else intersectionWithKey f s t1+                else E+  | otherwise = if p /= q then E+                else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1)+intersectionWithKey f (B p m s0 s1) (L k y) =+    case lookupM k (if zeroBit k m then s0 else s1) of+      Just x  -> L k (f k x y)+      Nothing -> E+intersectionWithKey f s@(B _ _ _ _) E = E+intersectionWithKey f (L k x) t =+    case lookupM k t of+      Just y  -> L k (f k x y)+      Nothing -> E+intersectionWithKey f E t = E++-- Datastructure definition is strict in all submaps,+-- no forcing required+strict n = n++strictWith f n@E = n+strictWith f n@(L i x) = f x `seq` n+strictWith f n@(B i j m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n+++ordListFM :: FM a -> [(Int,a)]+ordListFM E = []+ordListFM (L k x) = [(k,x)]+ordListFM (B p m t0 t1) = merge (ordListFM t0) (ordListFM t1)+  where merge [] ys = ys+        merge xs [] = xs+        merge (x@(k1,_):xs) (y@(k2,_):ys) =+           case compare k1 k2 of+              LT -> x : merge xs (y:ys)+              GT -> y : merge (x:xs) ys+              EQ -> error "PatriciaLoMap: bug in ordListFM"++ordListFM_rev :: FM a -> [(Int,a)]+ordListFM_rev E = []+ordListFM_rev (L k x) = [(k,x)]+ordListFM_rev (B p m t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1)+  where merge [] ys = ys+        merge xs [] = xs+        merge (x@(k1,_):xs) (y@(k2,_):ys) =+         case compare k1 k2 of+            LT -> y : merge (x:xs) ys+            GT -> x : merge xs (y:ys)+            EQ -> error "PatriciaLoMap: bug in ordListFM_rev"++minView :: Monad m => FM a -> m (a, FM a)+minView fm = +   case ordListFM fm of+     [] -> fail $ moduleName++".minView: empty map"+     ((k,x):_) -> return (x,delete k fm)++minViewWithKey :: Monad m => FM a -> m ((Int, a), FM a)+minViewWithKey fm =+   case ordListFM fm of+     [] -> fail $ moduleName++".minViewWithKey: empty map"+     ((k,x):_) -> return ((k,x),delete k fm)++maxView :: Monad m => FM a -> m (a, FM a)+maxView fm =+  case ordListFM_rev fm of+     [] -> fail $ moduleName++".maxView: empty map"+     ((k,x):_) -> return (x,delete k fm)++maxViewWithKey :: Monad m => FM a -> m ((Int, a), FM a)+maxViewWithKey fm =+   case ordListFM_rev fm of+     [] -> fail $ moduleName++".maxViewWithKey: empty map"+     ((k,x):_) -> return ((k,x),delete k fm)++minElem :: FM a -> a+minElem = minElemUsingMinView++minElemWithKey :: FM a -> (Int,a)+minElemWithKey = minElemWithKeyUsingMinViewWithKey++deleteMin :: FM a -> FM a+deleteMin = deleteMinUsingMinView++unsafeInsertMin :: Int -> a -> FM a -> FM a+unsafeInsertMin = insert++maxElem :: FM a -> a+maxElem = maxElemUsingMaxView++deleteMax :: FM a -> FM a+deleteMax = deleteMaxUsingMaxView++maxElemWithKey :: FM a -> (Int,a)+maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey++unsafeInsertMax :: Int -> a -> FM a -> FM a+unsafeInsertMax = insert++foldr :: (a -> b -> b) -> b -> FM a -> b+foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm++foldr' :: (a -> b -> b) -> b -> FM a -> b+foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm++foldr1 :: (a -> a -> a) -> FM a -> a+foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm++foldr1' :: (a -> a -> a) -> FM a -> a+foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm++foldl :: (b -> a -> b) -> b -> FM a -> b+foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm++foldl' :: (b -> a -> b) -> b -> FM a -> b+foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm++foldl1 :: (a -> a -> a) -> FM a -> a+foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm++foldl1' :: (a -> a -> a) -> FM a -> a+foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm++foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b+foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm++foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b+foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm++foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b+foldlWithKey f z fm = L.foldr (\ (k,x) z -> f z k x) z . ordListFM_rev $ fm++foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b+foldlWithKey' f z fm = L.foldl' (\ z (k,x) -> f z k x) z . ordListFM $ fm+++unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a+unsafeFromOrdSeq = fromSeq++unsafeAppend :: FM a -> FM a -> FM a+unsafeAppend = union++filterLT :: Int -> FM a -> FM a+filterLT k = filterWithKey (\k' _ -> k' < k)++filterLE :: Int -> FM a -> FM a+filterLE k = filterWithKey (\k' _ -> k' <= k)++filterGT :: Int -> FM a -> FM a+filterGT k = filterWithKey (\k' _ -> k' > k)++filterGE :: Int -> FM a -> FM a+filterGE k = filterWithKey (\k' _ -> k' >= k)++partitionLT_GE :: Int -> FM a -> (FM a, FM a)+partitionLT_GE k fm = (filterLT k fm,filterGE k fm)++partitionLE_GT :: Int -> FM a -> (FM a,FM a)+partitionLE_GT k fm = (filterLE k fm,filterGT k fm)++partitionLT_GT :: Int -> FM a -> (FM a,FM a)+partitionLT_GT k fm = (filterLT k fm,filterGT k fm)++toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a)+toOrdSeq = L.foldr S.lcons S.empty . ordListFM++-- defaults++insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a+insertSeq = insertSeqUsingFoldr++unionSeq :: S.Sequence seq => seq (FM a) -> FM a+unionSeq = unionSeqUsingReduce++deleteAll :: Int -> FM a -> FM a+deleteAll = delete++deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a+deleteSeq = deleteSeqUsingFoldr++count :: Int -> FM a -> Int+count = countUsingMember++lookupAll :: S.Sequence seq => Int -> FM a -> seq a+lookupAll = lookupAllUsingLookupM++lookupWithDefault :: a -> Int -> FM a -> a+lookupWithDefault = lookupWithDefaultUsingLookupM++elements :: S.Sequence seq => FM a -> seq a+elements = elementsUsingFold++fromSeqWithKey :: +    S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a+fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey++insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a+insertWithKey = insertWithKeyUsingInsertWith++insertSeqWith :: +    S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a+insertSeqWith = insertSeqWithUsingInsertWith++insertSeqWithKey :: +    S.Sequence seq => +      (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a+insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey++adjustAll :: (a -> a) -> Int -> FM a -> FM a+adjustAll = adjust++unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a+unionSeqWith = unionSeqWithUsingReduce++toSeq :: S.Sequence seq => FM a -> seq (Int,a)+toSeq = toSeqUsingFoldWithKey++keys :: S.Sequence seq => FM a -> seq Int+keys = keysUsingFoldWithKey+  +unionSeqWithKey :: +    S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a+unionSeqWithKey = unionSeqWithKeyUsingReduce++-- instance declarations++instance A.AssocX FM Int where+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; +   insertSeq = insertSeq; union = union; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; +   null = null; size = size; member = member; count = count; +   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;+   lookupAndDeleteAll = lookupAndDeleteAll;+   lookupWithDefault = lookupWithDefault; adjust = adjust;+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;+   adjustAllOrInsert = adjustAllOrInsert;+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; elements = elements;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName m = moduleName}++instance A.Assoc FM Int where+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; +   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';+   filterWithKey = filterWithKey; +   partitionWithKey = partitionWithKey}++instance A.FiniteMapX FM Int where+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; +   insertWith = insertWith; insertWithKey = insertWithKey; +   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; +   unionl = unionl; unionr = unionr; unionWith = unionWith; +   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; +   difference = difference; properSubset = properSubset; subset = subset;+   properSubmapBy = properSubmapBy; submapBy = submapBy;+   sameMapBy = sameMapBy}++instance A.FiniteMap FM Int where+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; +   intersectionWithKey = intersectionWithKey}++instance A.OrdAssocX FM Int where+  {minView = minView; minElem = minElem; deleteMin = deleteMin;+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance A.OrdAssoc FM Int where+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';+   toOrdSeq = toOrdSeq}++instance A.OrdFiniteMapX FM Int+instance A.OrdFiniteMap FM Int++instance Functor FM where+  fmap = map++instance (Show a) => Show (FM a) where+  showsPrec = showsPrecUsingToList++instance (Read a) => Read (FM a) where+  readsPrec = readsPrecUsingFromList++instance (Eq a) => Eq (FM a) where+  (==) = sameMap++instance (Ord a) => Ord (FM a) where+  compare = compareUsingToOrdList++instance (Arbitrary a) => Arbitrary (FM a) where+   arbitrary = do xs <- arbitrary+                  return (Prelude.foldr (uncurry insert) empty xs)++   coarbitrary E = variant 0+   coarbitrary (L i a) = variant 1 . coarbitrary i . coarbitrary a+   coarbitrary (B i j m n) = variant 2 . coarbitrary i . coarbitrary j+                           . coarbitrary m . coarbitrary n+++instance Monoid (FM a) where+   mempty  = empty+   mappend = union+   mconcat = unionSeq
+ src/Data/Edison/Assoc/StandardMap.hs view
@@ -0,0 +1,372 @@+-- |+--   Module      :  Data.Edison.Assoc.AssocList+--   Copyright   :  Copyright (c) 2006 Robert Dockins+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   The standard library "Data.Map" repackaged as an Edison+--   associative collection.++module Data.Edison.Assoc.StandardMap (+    -- * Type of standard finite maps+    FM,++    -- * AssocX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,++    -- * FiniteMapX operations+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,+    properSubmap,submap,sameMap,++    -- * OrdAssocX operations+    minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,+    unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',+    foldl1, foldl1', unsafeFromOrdSeq,+    unsafeAppend, filterLT, filterLE, filterGT, filterGE,+    partitionLT_GE, partitionLE_GT, partitionLT_GT,++    -- * Assoc operations+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,++    -- * OrdAssoc operations+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,++    -- * FiniteMap operations+    unionWithKey,unionSeqWithKey,intersectionWithKey,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)+import qualified Prelude+import Control.Monad.Identity (runIdentity)+import Data.Edison.Prelude+import qualified Data.Edison.Assoc as A+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Assoc.Defaults+import Data.Int+import Data.Bits+import Test.QuickCheck (Arbitrary(..))++import qualified Data.Map as DM++type FM = DM.Map++moduleName :: String+moduleName = "Data.Edison.Assoc.StandardMap"++empty             :: FM k a+singleton         :: Ord k => k -> a -> FM k a+fromSeq           :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a+insert            :: Ord k => k -> a -> FM k a -> FM k a+insertSeq         :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a+union             :: Ord k => FM k a -> FM k a -> FM k a+unionSeq          :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a+delete            :: Ord k => k -> FM k a -> FM k a+deleteAll         :: Ord k => k -> FM k a -> FM k a+deleteSeq         :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a+null              :: FM k a -> Bool+size              :: FM k a -> Int+member            :: Ord k => k -> FM k a -> Bool+count             :: Ord k => k -> FM k a -> Int+lookup            :: Ord k => k -> FM k a -> a+lookupAll         :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a+lookupM           :: (Ord k,Monad m) => k -> FM k a -> m a+lookupWithDefault :: Ord k => a -> k -> FM k a -> a+lookupAndDelete   :: Ord k => k -> FM k a -> (a, FM k a)+lookupAndDeleteM  :: (Ord k,Monad m) => k -> FM k a -> m (a, FM k a)+lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)+adjust            :: Ord k => (a->a) -> k -> FM k a -> FM k a+adjustAll         :: Ord k => (a->a) -> k -> FM k a -> FM k a+adjustOrInsert    :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a+adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a+adjustOrDelete    :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a+adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a+strict            :: Ord k => FM k a -> FM k a+strictWith        :: Ord k => (a -> b) -> FM k a -> FM k a+map               :: (Ord k,Functor (FM k)) => (a -> b) -> FM k a -> FM k b+fold              :: Ord k => (a -> b -> b) -> b -> FM k a -> b+fold1             :: Ord k => (a -> a -> a) -> FM k a -> a+fold'             :: Ord k => (a -> b -> b) -> b -> FM k a -> b+fold1'            :: Ord k => (a -> a -> a) -> FM k a -> a+filter            :: Ord k => (a -> Bool) -> FM k a -> FM k a+partition         :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a)+elements          :: (Ord k,S.Sequence seq) => FM k a -> seq a++minView           :: (Ord k,Monad m) => FM k a -> m (a, FM k a)+minElem           :: Ord k => FM k a -> a+deleteMin         :: Ord k => FM k a -> FM k a+unsafeInsertMin   :: Ord k => k -> a -> FM k a -> FM k a+maxView           :: (Ord k,Monad m) => FM k a -> m (a, FM k a)+maxElem           :: Ord k => FM k a -> a+deleteMax         :: Ord k => FM k a -> FM k a+unsafeInsertMax   :: Ord k => k -> a -> FM k a -> FM k a+foldr             :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldl             :: Ord k => (b -> a -> b) -> b -> FM k a -> b+foldr1            :: Ord k => (a -> a -> a) -> FM k a -> a+foldl1            :: Ord k => (a -> a -> a) -> FM k a -> a+foldr'            :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldl'            :: Ord k => (b -> a -> b) -> b -> FM k a -> b+foldr1'           :: Ord k => (a -> a -> a) -> FM k a -> a+foldl1'           :: Ord k => (a -> a -> a) -> FM k a -> a+unsafeFromOrdSeq  :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a+unsafeAppend      :: Ord k => FM k a -> FM k a -> FM k a+filterLT          :: Ord k => k -> FM k a -> FM k a+filterGT          :: Ord k => k -> FM k a -> FM k a+filterLE          :: Ord k => k -> FM k a -> FM k a+filterGE          :: Ord k => k -> FM k a -> FM k a+partitionLT_GE    :: Ord k => k -> FM k a -> (FM k a,FM k a)+partitionLE_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)+partitionLT_GT    :: Ord k => k -> FM k a -> (FM k a,FM k a)++fromSeqWith       :: (Ord k,S.Sequence seq) => (a -> a -> a) +                         -> seq (k,a) -> FM k a+fromSeqWithKey    :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)+                         -> seq (k,a) -> FM k a+insertWith        :: Ord k => (a -> a -> a) -> k -> a+	                 -> FM k a -> FM k a+insertWithKey     :: Ord k => (k -> a -> a -> a) -> k -> a+                         -> FM k a -> FM k a+insertSeqWith     :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a)+                         -> FM k a -> FM k a+insertSeqWithKey  :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a)+                         -> FM k a -> FM k a+unionl            :: Ord k => FM k a -> FM k a -> FM k a+unionr            :: Ord k => FM k a -> FM k a -> FM k a+unionWith         :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWith      :: (Ord k,S.Sequence seq) =>+                         (a -> a -> a) -> seq (FM k a) -> FM k a+intersectionWith  :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c+difference        :: Ord k => FM k a -> FM k b -> FM k a+properSubset      :: Ord k => FM k a -> FM k b -> Bool+subset            :: Ord k => FM k a -> FM k b -> Bool+properSubmapBy    :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+submapBy          :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+sameMapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+properSubmap      :: (Ord k,Eq a) => FM k a -> FM k a -> Bool+submap            :: (Ord k,Eq a) => FM k a -> FM k a -> Bool+sameMap           :: (Ord k,Eq a) => FM k a -> FM k a -> Bool++toSeq             :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)+keys              :: (Ord k,S.Sequence seq) => FM k a -> seq k+mapWithKey        :: Ord k => (k -> a -> b) -> FM k a -> FM k b+foldWithKey       :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b+foldWithKey'      :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b+filterWithKey     :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a+partitionWithKey  :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a)++minViewWithKey    :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)+minElemWithKey    :: Ord k => FM k a -> (k,a)+maxViewWithKey    :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)+maxElemWithKey    :: Ord k => FM k a -> (k,a)+foldrWithKey      :: (k -> a -> b -> b) -> b -> FM k a -> b+foldlWithKey      :: (b -> k -> a -> b) -> b -> FM k a -> b+foldrWithKey'     :: (k -> a -> b -> b) -> b -> FM k a -> b+foldlWithKey'     :: (b -> k -> a -> b) -> b -> FM k a -> b+toOrdSeq          :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)++unionWithKey      :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWithKey   :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)+                        -> seq (FM k a) -> FM k a+intersectionWithKey  :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c++structuralInvariant :: Ord k => FM k a -> Bool+structuralInvariant = DM.valid+++empty              = DM.empty+singleton          = DM.singleton+fromSeq            = fromSeqUsingInsertSeq+insert             = DM.insert+insertSeq          = insertSeqUsingFoldr+union              = DM.union+unionSeq           = DM.unions . S.toList+delete             = DM.delete+deleteAll          = DM.delete -- by finite map property+deleteSeq          = deleteSeqUsingFoldr+null               = DM.null+size               = DM.size+member             = DM.member+count              = countUsingMember+lookup k m         = case lookupM k m of+                         Nothing -> error (moduleName ++ ".lookup: failed")+                         Just x  -> x+lookupM            = DM.lookup+lookupAll          = lookupAllUsingLookupM+lookupWithDefault  = DM.findWithDefault+lookupAndDelete    = lookupAndDeleteDefault+lookupAndDeleteM   = lookupAndDeleteMDefault+lookupAndDeleteAll = lookupAndDeleteAllDefault+adjust             = DM.adjust+adjustAll          = DM.adjust+adjustOrInsert     = adjustOrInsertUsingMember+adjustAllOrInsert  = adjustOrInsertUsingMember+adjustOrDelete     = DM.update+adjustOrDeleteAll  = DM.update+strict xs          = DM.fold (flip const) () xs `seq` xs+strictWith f xs    = DM.fold (\x z -> f x `seq` z) () xs `seq` xs+map                = fmap+fold               = DM.fold+fold' f x xs       = L.foldl' (flip f) x (DM.elems xs)+fold1  f xs        = L.foldr1 f (DM.elems xs)+fold1' f xs        = L.foldl1' (flip f) (DM.elems xs)+filter             = DM.filter+partition          = DM.partition+elements           = elementsUsingFold++minView m          = if DM.null m+                       then fail (moduleName ++ ".minView: failed")+                       else let ((k,x),m') = DM.deleteFindMin m +                            in return (x,m')+minElem            = snd . DM.findMin+deleteMin          = DM.deleteMin+unsafeInsertMin    = DM.insert+maxView m          = if DM.null m+                       then fail (moduleName ++ ".maxView: failed")+                       else let ((k,x),m') = DM.deleteFindMax m +                            in return (x,m')+maxElem            = snd . DM.findMax+deleteMax          = DM.deleteMax+unsafeInsertMax    = DM.insert+foldr   f x m      = L.foldr   f x (DM.elems m)+foldl   f x m      = L.foldl   f x (DM.elems m)+foldr1  f   m      = L.foldr1  f   (DM.elems m)+foldl1  f   m      = L.foldl1  f   (DM.elems m)+foldr'  f x m      = L.foldr'  f x (DM.elems m)+foldl'  f x m      = L.foldl'  f x (DM.elems m)+foldr1' f   m      = L.foldr1' f   (DM.elems m)+foldl1' f   m      = L.foldl1' f   (DM.elems m)+unsafeFromOrdSeq   = DM.fromAscList . S.toList+unsafeAppend       = DM.union+filterLT k         = fst . DM.split k+filterGT k         = snd . DM.split k+filterLE k m       = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx+filterGE k m       = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx+partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx)+partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt)+partitionLT_GT     = DM.split+fromSeqWith    f s = DM.fromListWith    f (S.toList s)+fromSeqWithKey f s = DM.fromListWithKey f (S.toList s)+insertWith         = DM.insertWith+insertWithKey      = insertWithKeyUsingInsertWith+insertSeqWith      = insertSeqWithUsingInsertWith+insertSeqWithKey   = insertSeqWithKeyUsingInsertWithKey+unionl             = DM.union+unionr             = flip DM.union+unionWith          = DM.unionWith+unionSeqWith       = unionSeqWithUsingReduce+intersectionWith   = DM.intersectionWith+difference         = DM.difference+properSubset       = DM.isProperSubmapOfBy (\_ _ -> True)+subset             = DM.isSubmapOfBy (\_ _ -> True)+properSubmapBy     = DM.isProperSubmapOfBy+submapBy           = DM.isSubmapOfBy+sameMapBy          = sameMapByUsingOrdLists+properSubmap       = A.properSubmap+submap             = A.submap+sameMap            = A.sameMap++toSeq              = toSeqUsingFoldWithKey+keys               = keysUsingFoldWithKey+mapWithKey         = DM.mapWithKey+foldWithKey        = DM.foldWithKey+foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m)+filterWithKey      = DM.filterWithKey+partitionWithKey   = DM.partitionWithKey++minViewWithKey m   = if DM.null m+                        then fail (moduleName ++ ".minViewWithKey: failed")+	                else return (DM.deleteFindMin m)+minElemWithKey     = DM.findMin+maxViewWithKey m   = if DM.null m+                        then fail (moduleName ++ ".maxViewWithKey: failed")+	                else return (DM.deleteFindMax m)+maxElemWithKey     = DM.findMax+foldrWithKey        = DM.foldWithKey+foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m)+foldlWithKey  f x m = L.foldl  (\b (k,a) -> f b k a) x (DM.toAscList m)+foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m)+toOrdSeq           = S.fromList . DM.toAscList++unionWithKey       = DM.unionWithKey+unionSeqWithKey    = unionSeqWithKeyUsingReduce+intersectionWithKey = DM.intersectionWithKey+++instance Ord k => A.AssocX (FM k) k where+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; union = union; unionSeq = unionSeq;+   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;+   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;+   lookupAndDeleteAll = lookupAndDeleteAll;+   lookupWithDefault = lookupWithDefault; adjust = adjust;+   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;+   adjustAllOrInsert = adjustAllOrInsert;+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; elements = elements;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName m = moduleName}++instance Ord k => A.OrdAssocX (FM k) k where+  {minView = minView; minElem = minElem; deleteMin = deleteMin;+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;+   filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;+   filterGE = filterGE; partitionLT_GE = partitionLT_GE;+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord k => A.FiniteMapX (FM k) k where+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;+   insertWith = insertWith; insertWithKey = insertWithKey;+   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;+   unionl = unionl; unionr = unionr; unionWith = unionWith;+   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;+   difference = difference; properSubset = properSubset; subset = subset;+   properSubmapBy = properSubmapBy; submapBy = submapBy;+   sameMapBy = sameMapBy}++instance Ord k => A.OrdFiniteMapX (FM k) k++instance Ord k => A.Assoc (FM k) k where+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;+   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';+   filterWithKey = filterWithKey;+   partitionWithKey = partitionWithKey}++instance Ord k => A.OrdAssoc (FM k) k where+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';+   toOrdSeq = toOrdSeq}++instance Ord k => A.FiniteMap (FM k) k where+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;+   intersectionWithKey = intersectionWithKey}++instance Ord k => A.OrdFiniteMap (FM k) k++instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where+   arbitrary = do xs <- arbitrary+                  return (Prelude.foldr (uncurry insert) empty xs)++   coarbitrary map = coarbitrary (A.toList map)
+ src/Data/Edison/Assoc/TernaryTrie.hs view
@@ -0,0 +1,1149 @@+-- |+--   Module      :  Data.Edison.Assoc.TernaryTrie+--   Copyright   :  Copyright (c) 2002 Andrew Bromage+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Finite maps implemented as ternary search tries++module Data.Edison.Assoc.TernaryTrie (+    -- * Type of ternary search tries+    FM,++    -- * AssocX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,+    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,+    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,+    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,+    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,++    -- * Assoc operations+    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,++    -- * FiniteMapX operations+    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,+    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,+    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,+    properSubmap,submap,sameMap,++    -- * FiniteMap operations+    unionWithKey,unionSeqWithKey,intersectionWithKey,++    -- * OrdAssocX operations+    minView, minElem, deleteMin, unsafeInsertMin,+    maxView, maxElem, deleteMax, unsafeInsertMax,+    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',+    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,+    partitionLT_GE, partitionLE_GT, partitionLT_GT,++    -- * OrdAssoc operations+    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,+    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',+    toOrdSeq,++    -- * Other supported operations+    mergeVFM, mergeKVFM,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)+import qualified Prelude+import Data.Edison.Prelude+import qualified Data.Edison.Assoc as A+import qualified Data.Edison.Seq as S+import qualified Data.List as L+import Control.Monad.Identity+import Data.Monoid+import Data.Edison.Assoc.Defaults+import Test.QuickCheck (Arbitrary(..), variant)++import Maybe (isNothing)++-- signatures for exported functions+moduleName    :: String+empty         :: Ord k => FM k a+singleton     :: Ord k => [k] -> a -> FM k a+fromSeq       :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a+insert        :: Ord k => [k] -> a -> FM k a -> FM k a+insertSeq     :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a+union         :: Ord k => FM k a -> FM k a -> FM k a+unionSeq      :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a+delete        :: Ord k => [k] -> FM k a -> FM k a+deleteAll     :: Ord k => [k] -> FM k a -> FM k a+deleteSeq     :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a+null          :: Ord k => FM k a -> Bool+size          :: Ord k => FM k a -> Int+member        :: Ord k => [k] -> FM k a -> Bool+count         :: Ord k => [k] -> FM k a -> Int+lookup        :: Ord k => [k] -> FM k a -> a+lookupM       :: (Ord k, Monad rm) => [k] -> FM k a -> rm a+lookupAll     :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a+lookupAndDelete    :: Ord k => [k] -> FM k a -> (a, FM k a)+lookupAndDeleteM   :: (Ord k, Monad rm) => [k] -> FM k a -> rm (a, FM k a)+lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a)+lookupWithDefault  :: Ord k => a -> [k] -> FM k a -> a+adjust        :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a+adjustAll     :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a+adjustOrInsert    :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a+adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a+adjustOrDelete    :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a+adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a+strict            :: FM k a -> FM k a+strictWith        :: (a -> b) -> FM k a -> FM k a+map           :: Ord k => (a -> b) -> FM k a -> FM k b+fold          :: Ord k => (a -> b -> b) -> b -> FM k a -> b+fold1         :: Ord k => (a -> a -> a) -> FM k a -> a+fold'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b+fold1'        :: Ord k => (a -> a -> a) -> FM k a -> a+filter        :: Ord k => (a -> Bool) -> FM k a -> FM k a+partition     :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a)+elements      :: (Ord k,S.Sequence seq) => FM k a -> seq a++fromSeqWith      :: (Ord k,S.Sequence seq) => +                        (a -> a -> a) -> seq ([k],a) -> FM k a+fromSeqWithKey   :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a+insertWith       :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a+insertWithKey    :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a+insertSeqWith    :: (Ord k,S.Sequence seq) => +                        (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a+insertSeqWithKey :: (Ord k,S.Sequence seq) => +                        ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a+unionl           :: Ord k => FM k a -> FM k a -> FM k a+unionr           :: Ord k => FM k a -> FM k a -> FM k a+unionWith        :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWith     :: (Ord k,S.Sequence seq) => +                        (a -> a -> a) -> seq (FM k a) -> FM k a+intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c+difference       :: Ord k => FM k a -> FM k b -> FM k a+properSubset     :: Ord k => FM k a -> FM k b -> Bool    +subset           :: Ord k => FM k a -> FM k b -> Bool    +properSubmapBy   :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+submapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+sameMapBy        :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool+properSubmap     :: (Ord k, Eq a) => FM k a -> FM k a -> Bool+submap           :: (Ord k, Eq a) => FM k a -> FM k a -> Bool+sameMap          :: (Ord k, Eq a) => FM k a -> FM k a -> Bool++toSeq            :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)+keys             :: (Ord k,S.Sequence seq) => FM k a -> seq [k]+mapWithKey       :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b+foldWithKey      :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b+foldWithKey'     :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b+filterWithKey    :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a+partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a)+unionWithKey     :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a+unionSeqWithKey  :: (Ord k,S.Sequence seq) => +                       ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a+intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c++foldr          :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldr1         :: Ord k => (a -> a -> a) -> FM k a -> a+foldr'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b+foldr1'        :: Ord k => (a -> a -> a) -> FM k a -> a++foldrWithKey   :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b+foldrWithKey'  :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b+foldlWithKey   :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b+foldlWithKey'  :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b+toOrdSeq       :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)++moduleName = "Data.Edison.Assoc.TernaryTrie"+++data FM k a+  = FM !(Maybe a) !(FMB k a)++data FMB k v+  = E+  | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v)++newtype FMB' k v+  = FMB' (FMB k v)++balance :: Int+balance = 6++sizeFMB :: FMB k v -> Int+sizeFMB E = 0+sizeFMB (I size _ _ _ _ _) = size++mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v+mkFMB k v l m r+  = I (1 + sizeFMB l + sizeFMB r) k v l m r++lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v+lookupFMB []        _+  = Nothing+lookupFMB nk@(x:xs) E+  = Nothing+lookupFMB nk@(x:xs) (I _ k v l m@(FMB' fmbm) r)+  = case compare x k of+        LT -> lookupFMB nk l+        GT -> lookupFMB nk r+        EQ -> if L.null xs then v else lookupFMB xs fmbm++listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v+listToFMB [x]    fv = mkFMB x (fv Nothing) E (FMB' E)                 E+listToFMB (x:xs) fv = mkFMB x Nothing      E (FMB' $ listToFMB xs fv) E+listToFMB _ _ = error "TernaryTrie.listToFMB: bug!"++addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v+addToFMB xs combiner E+  = listToFMB xs combiner+addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r)+  = case compare x k of+        LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r+        GT -> mkBalancedFMB k v l m (addToFMB nk combiner r)+        EQ -> case xs of+                [] -> I size k (combiner v) l m r+                _  -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r+addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!"++addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v+addToFM [] combiner (FM n fmb)+  = FM (combiner n) fmb+addToFM xs combiner (FM n fmb)+  = FM n (addToFMB xs combiner fmb)++lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z+lookupAndDelFromFMB onFail cont xs E = onFail+lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r)+  = case compare x k of+        LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l+        GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r+        EQ -> case xs of+                [] -> case v of+                        Nothing -> onFail+                        Just w  -> case fmbm of+                                      E -> cont w (appendFMB l r)+                                      _ -> cont w (I size k Nothing l m r)+                _  -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm+lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!"++lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z+lookupAndDelFromFM onFail cont [] (FM Nothing fmb)  = onFail+lookupAndDelFromFM onFail cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb)+lookupAndDelFromFM onFail cont xs (FM n fmb) =+   lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb+++delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v+delFromFMB xs E+  = E+delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r)+  = case compare x k of+        LT -> mkBalancedFMB k v (delFromFMB nk l) m r+        GT -> mkBalancedFMB k v l m (delFromFMB nk r)+        EQ -> case xs of+                [] -> case fmbm of+                        E -> appendFMB l r+                        _ -> I size k Nothing l m r+                _  -> I size k v l (FMB' $ delFromFMB xs fmbm) r+delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!"+++delFromFM :: (Ord k) => [k] -> FM k v -> FM k v+delFromFM [] (FM n fmb)+  = FM Nothing fmb+delFromFM xs (FM n fmb)+  = FM n (delFromFMB xs fmb)+++mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v+mkBalancedFMB k v l m r+  | size_l + size_r < 2+    = mkFMB k v l m r+  | size_r > balance * size_l        -- Right tree too big+    = case r of+        I _ _ _ rl _ rr+            | sizeFMB rl < 2 * sizeFMB rr+                -> single_L l m r+            | otherwise+                -> double_L l m r+        _ -> error "TernaryTrie.mkBalancedFMB: bug!"++  | size_l > balance * size_r   -- Left tree too big+    = case l of+        I _ _ _ ll _ lr+            | sizeFMB lr < 2 * sizeFMB ll+                -> single_R l m r+            | otherwise+                -> double_R l m r+        _ -> error "TernaryTrie.mkBalancedFMB: bug!"++  | otherwise                           -- No imbalance+    = mkFMB k v l m r+  where+        size_l   = sizeFMB l+        size_r   = sizeFMB r++        single_L l m (I _ k_r v_r rl rm rr)+          = mkFMB k_r v_r (mkFMB k v l m rl) rm rr+        single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"++        double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr)+          = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr)+        double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"++        single_R (I _ k_l v_l ll lm lr) m r+          = mkFMB k_l v_l ll lm (mkFMB k v lr m r)+        single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"++        double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r+          = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r)+        double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"+++mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v+mkVBalancedFMB k v E m E+  = mkFMB k v E m E+mkVBalancedFMB k v l@E m r@(I _ kr vr rl rm rr)+  = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr+mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@E+  = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)+mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr)+  | balance * size_l < size_r+    = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr+  | balance * size_r < size_l+    = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)+  | otherwise+    = mkFMB k v l m r+  where+        size_l = sizeFMB l+        size_r = sizeFMB r++    -- Constraint: All keys in the first FMB are less than+    -- that in the second FMB.+appendFMB :: FMB k v -> FMB k v -> FMB k v+appendFMB E m2 = m2+appendFMB m1 E = m1+appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2)+  | size1 > size2+    = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2)+  | otherwise+    = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2++mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b+mapVFM f (FM n fmb)+  = FM (f n) (mapVFMB f fmb)++mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b+mapVFMB f m+  = mapVFMB' m+  where+        mapVFMB' E = E+        mapVFMB' (I _ k v l (FMB' m) r)+          = case (mapVFMB' m, f v) of+                (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r)+                (m',v')     -> mkVBalancedFMB k v'+                                    (mapVFMB' l) (FMB' m') (mapVFMB' r)++mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b+mapKVFM f (FM n fmb)+  = FM (f [] n) (mapKVFMB [] fmb)+  where+        mapKVFMB _ E = E+        mapKVFMB ks (I size k v l (FMB' m) r)+          = mkVBalancedFMB k (f (reverse (k:ks)) v)+              (mapKVFMB ks l)+              (FMB' (mapKVFMB (k:ks) m))+              (mapKVFMB ks r)++nullFMB :: FMB k v -> Bool+nullFMB E = True+nullFMB (I _ _ v l (FMB' m) r)+  = case v of+      Just _  -> False+      Nothing -> nullFMB l && nullFMB m && nullFMB r++nullFM :: FM k v -> Bool+nullFM (FM (Just _) _)  = False+nullFM (FM Nothing fmb) = nullFMB fmb++data FMBCtx k v+  = T+  | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v)+  | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v)++splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a)+splayFMB key fmb+  = splaydown T fmb+  where+    splaydown ctx E+      = splayup ctx Nothing E (FMB' E) E+    splaydown ctx y@(I _ k v l m r)+      = case compare key k of+            LT -> splaydown (L k v ctx m r) l+            GT -> splaydown (R k v l m ctx) r+            EQ -> splayup ctx v l m r++    splayup ctx v l m r+      = splayup' ctx l r+      where+          splayup' T l r+            = (v, l, m, r)+          splayup' (L ck cv ctx cm cr) tl tr+            = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr)+          splayup' (R ck cv cl cm ctx) tl tr+            = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr++mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->+                FMB k a -> FMB k b -> FMB k c+mergeVFMB f fmbx fmby+  = mergeVFMB' fmbx fmby+  where+    mergeVFMB' E E+      = E+    mergeVFMB' E fmby@(I _ k v l (FMB' m) r)+      = mapVFMB (\v -> f Nothing v) fmby+    mergeVFMB' fmbx@(I _ k v l (FMB' m) r) E+      = mapVFMB (\v -> f v Nothing) fmbx+    mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx)+               fmby@(I sizey ky vy ly (FMB' my) ry)+      | sizex >= sizey+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby+          in case (mergeVFMB' mx my, f vx vy) of+                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)+                (m',v)      -> mkVBalancedFMB kx v+                                   (mergeVFMB' lx ly)+                                   (FMB' m')+                                   (mergeVFMB' rx ry)+      | otherwise+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx+          in case (mergeVFMB' mx my, f vx vy) of+                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)+                (m',v)      -> mkVBalancedFMB ky v+                                   (mergeVFMB' lx ly)+                                   (FMB' m')+                                   (mergeVFMB' rx ry)++mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->+                FM k a -> FM k b -> FM k c+mergeVFM f (FM vx fmbx) (FM vy fmby)+  = FM (f vx vy) (mergeVFMB f fmbx fmby)+++mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->+                FMB k a -> FMB k b -> FMB k c+mergeKVFMB f fmbx fmby+  = mergeKVFMB' [] fmbx fmby+  where+    mergeKVFMB' ks E E+      = E+    mergeKVFMB' ks E fmby+      = mergeKVFMBs (\k v -> f k Nothing v) ks fmby+    mergeKVFMB' ks fmbx E+      = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx+    mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx)+                   fmby@(I sizey ky vy ly (FMB' my) ry)+      | sizex >= sizey+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby+              ks' = reverse (kx:ks)+          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of+                (E,Nothing) -> appendFMB+                                    (mergeKVFMB' ks lx ly)+                                    (mergeKVFMB' ks rx ry)+                (m',v)      -> mkVBalancedFMB kx v+                                    (mergeKVFMB' ks lx ly)+                                    (FMB' m')+                                    (mergeKVFMB' ks rx ry)+      | otherwise+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx+              ks' = reverse (ky:ks)+          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of+                (E,Nothing) -> appendFMB+                                    (mergeKVFMB' ks lx ly)+                                    (mergeKVFMB' ks rx ry)+                (m',v)      -> mkVBalancedFMB ky v+                                    (mergeKVFMB' ks lx ly)+                                    (FMB' m')+                                    (mergeKVFMB' ks rx ry)++    mergeKVFMBs f ks fmb+      = mergeKVFMBs' ks fmb+      where+          mergeKVFMBs' ks E+            = E+          mergeKVFMBs' ks (I s k v l (FMB' m) r)+            = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of+                (E, Nothing) -> appendFMB+                                    (mergeKVFMBs' ks l)+                                    (mergeKVFMBs' ks r)+                (m,v)        -> mkVBalancedFMB k v+                                    (mergeKVFMBs' ks l)+                                    (FMB' m)+                                    (mergeKVFMBs' ks r)++mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->+                FM k a -> FM k b -> FM k c+mergeKVFM f (FM vx fmbx) (FM vy fmby)+  = FM (f [] vx vy) (mergeKVFMB f fmbx fmby)+++-- The public interface.+--  ++-- AssocX++empty = FM Nothing E++singleton [] v = FM (Just v) E+singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v))++fromSeq = fromSeqUsingInsertSeq++insert k v fm = addToFM k (\_ -> Just v) fm++insertSeq = insertSeqUsingFoldr++union = mergeVFM mplus++unionSeq = unionSeqUsingReduce++delete k fm = delFromFM k fm++deleteAll = delete++deleteSeq = deleteSeqUsingFoldr++null = nullFM++size (FM k fmb) +    | isNothing k = fmb_size fmb 0+    | otherwise   = fmb_size fmb 1+    where fmb_size E k = k+          fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k+          fmb_size (I _ _ _ l (FMB' m) r ) k      = fmb_size l $ fmb_size m $ fmb_size r $! k+1+++member = memberUsingLookupM++count = countUsingMember++lookup m k = runIdentity (lookupM m k)++lookupM [] (FM Nothing _)+  = fail "TernaryTrie.lookup: lookup failed"+lookupM [] (FM (Just v) _)+  = return v+lookupM xs (FM _ fmb)+  = case  lookupFMB xs fmb  of+        Nothing -> fail "TernaryTrie.lookup: lookup failed"+        Just v  -> return v++lookupAll = lookupAllUsingLookupM++lookupAndDelete =+    lookupAndDelFromFM +      (error "TernaryTrie.lookupAndDelete: lookup failed")+      (,)++lookupAndDeleteM = +    lookupAndDelFromFM+      (fail  "TernaryTrie.lookupAndDeleteM: lookup failed")+      (\w m -> return (w,m))++lookupAndDeleteAll k m =+    lookupAndDelFromFM+      (S.empty,m)+      (\w m' -> (S.singleton w,m'))+      k m++lookupWithDefault = lookupWithDefaultUsingLookupM++adjust f k+  = addToFM k (\mv -> case mv of+                        Nothing -> mv+                        Just v  -> Just (f v))++adjustAll = adjust++adjustOrInsert f z k +  = addToFM k (\mv -> case mv of+                        Nothing -> Just z+                        Just v  -> Just (f v))++adjustAllOrInsert = adjustOrInsert++adjustOrDelete f k+  = addToFM k (\mv -> case mv of+                        Nothing -> mv+                        Just v  -> f v)++adjustOrDeleteAll = adjustOrDelete++map f+  = mapVFM (\mv -> case mv of+                        Nothing -> Nothing+                        Just v  -> Just (f v))++fold = foldr+fold' = foldr'++foldr op z (FM n fmb)+  = foldMV n . foldFMB fmb $ z+  where+    foldMV Nothing  = id+    foldMV (Just v) = op v++    foldFMB E+      = id+    foldFMB (I _ _ v l (FMB' m) r)+      = foldFMB l . foldMV v . foldFMB m . foldFMB r++foldrWithKey f z (FM n fmb)+  = foldMV [] n . foldFMB id fmb $ z+  where+     foldMV ks Nothing  = id+     foldMV ks (Just v) = f ks v++     foldFMB kf E = id+     foldFMB kf (I _ k mv l (FMB' m) r)+       = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r++foldlWithKey f z (FM n fmb)+  = foldFMB id fmb . foldMV [] n $ z+  where+     g k x a = f a k x++     foldMV ks Nothing  = id+     foldMV ks (Just v) = g ks v++     foldFMB kf E = id+     foldFMB kf (I _ k mv l (FMB' m) r)+       = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l++foldrWithKey' = foldrWithKey+foldlWithKey' = foldlWithKey++foldl op z (FM n fmb)+  = foldFMB fmb . foldMV n $ z+  where +    foldMV Nothing  = id+    foldMV (Just v) = (flip op) v++    foldFMB E = id+    foldFMB (I _ _ v l (FMB' m) r)+      = foldFMB r . foldFMB m . foldMV v . foldFMB l+++-- FIXME, undestand this code to strictify it+foldr' = foldr+foldl' = foldl++foldr1 f fm = +  case maxView fm of+     Just (z,fm') -> foldr f z fm'+     Nothing      -> error $ moduleName++".foldr1: empty map"++foldl1 f fm =+  case minView fm of+     Just (z,fm') -> foldl f z fm'+     Nothing      -> error $ moduleName++".foldl1: empty map"+++basecase Nothing  = \j n -> n+basecase (Just x) = \j n -> j x++comb f p1 p2+   = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n)++fold1 f (FM mv fmb)+  = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map")+  where+      fold1FMB E+        = \j n -> n+      fold1FMB (I _ _ mv l (FMB' m) r)+        = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r)++fold1' = fold1++{-+FIXME -- can these be somehow fixed to have the right order...++foldr1 f (FM v fmb)+  = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map")+  where+      fold1FMB E+        = \j n -> n+      fold1FMB (I _ _ v l (FMB' m) r)+        = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r)+++foldl1 f (FM v fmb)+  = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map")+  where+      fold1FMB E+        = \j n -> n+      fold1FMB (I _ _ v l (FMB' m) r)+        = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l)+-}++++-- FIXME, undestand this code to strictify it+foldr1' = foldr1+foldl1' = foldl1+++filter p = mapVFM (\mv -> case mv of+                            Nothing -> mv+                            Just v  -> if p v then mv else Nothing)++partition = partitionUsingFilter++elements = elementsUsingFold++strict z@(FM v fmb) = strictFMB fmb `seq` z+ where strictFMB n@E = n+       strictFMB n@(I i k v l (FMB' m) r) =+           strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n++strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z+   where f' v@Nothing  = v+         f' v@(Just x) = f x `seq` v++         strictWithFMB n@E = n+         strictWithFMB n@(I i k v l (FMB' m) r) =+           f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n+++-- FiniteMapX++fromSeqWith = fromSeqWithUsingInsertSeqWith++fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey++insertWith f k v+  = addToFM k (\vem ->+      case vem of+          Nothing -> Just v+          Just ve -> Just (f ve v))++insertWithKey = insertWithKeyUsingInsertWith++insertSeqWith = insertSeqWithUsingInsertWith++insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey++unionl = union+unionr = flip union++unionWith f = unionWithKey (const f)++unionSeqWith = unionSeqWithUsingReduce++intersectionWith f = intersectionWithKey (const f)++difference mx my+  = mergeVFM (\v1 v2 -> case v2 of+              Nothing -> v1+              Just _  -> Nothing) mx my++properSubset = properSubsetUsingSubset++subset (FM nx fmbx) (FM ny fmby)+  = subsetEqM nx ny && subsetEqFMB fmbx fmby+  where+    subsetEqM Nothing _ = True+    subsetEqM (Just _) Nothing = False+    subsetEqM (Just _) (Just _) = True++    subsetEqFMB E _ = True+    subsetEqFMB fmbx@(I _ _ _ _ _ _) E+      = nullFMB fmbx+    subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx)+            fmby@(I sizey ky vy ly (FMB' my) ry)+      | sizex >= sizey+        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby+          in    subsetEqM vx vy+             && subsetEqFMB lx ly+             && subsetEqFMB mx my+             && subsetEqFMB rx ry+      | otherwise+        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx+          in    subsetEqM vx vy+             && subsetEqFMB lx ly+             && subsetEqFMB mx my+             && subsetEqFMB rx ry+++submapBy = submapByUsingLookupM+properSubmapBy = properSubmapByUsingSubmapBy+sameMapBy = sameMapByUsingSubmapBy+properSubmap = A.properSubmap+submap = A.submap+sameMap = A.sameMap++-- Assoc++toSeq = toSeqUsingFoldWithKey++keys = keysUsingFoldWithKey++mapWithKey f+  = mapKVFM (\k mv -> case mv of+          Nothing -> Nothing+          Just v  -> Just (f k v))++foldWithKey op r (FM n fmb)+  = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r+  where+      foldWithKeyB k Nothing = id+      foldWithKeyB k (Just v) = op k v++      foldWithKeyFM ks E = id+      foldWithKeyFM ks (I _ k v l (FMB' m) r)+        = foldWithKeyFM ks l+        . foldWithKeyB (reverse (k:ks)) v+        . foldWithKeyFM (k:ks) m+        . foldWithKeyFM ks r+++-- FIXME, make this strict+foldWithKey' = foldWithKey+++filterWithKey f+  = mapKVFM (\k mv -> case mv of+          Nothing -> mv+          Just v  -> if f k v then mv else Nothing)++partitionWithKey f m+  = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m)++-- FiniteMap++unionWithKey f+  = mergeKVFM (\k v1m v2m ->+    case v1m of+        Nothing -> v2m+        Just v1 ->+            case v2m of+            Nothing -> v1m+            Just v2 -> Just (f k v1 v2))++unionSeqWithKey = unionSeqWithKeyUsingReduce++intersectionWithKey f+  = mergeKVFM (\k v1m v2m ->+    case v1m of+        Nothing -> Nothing+        Just v1 ->+            case v2m of+            Nothing -> Nothing+            Just v2 -> Just (f k v1 v2))++-- OrdAssocX++minViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)+minViewFMB E f = fail $ moduleName++".minView: empty map"+minViewFMB (I i k (Just v) E m r)        f = return (v, f (I i k Nothing E m r))+minViewFMB (I i k Nothing  E (FMB' E) r) f = error $ moduleName++".minView: bug!"+minViewFMB (I i k Nothing  E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))+minViewFMB (I i k mv l m r)              f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r))++minView :: Monad m => FM k a -> m (a,FM k a)+minView (FM (Just v) fmb) = return (v, FM Nothing fmb)+minView (FM Nothing fmb)  = minViewFMB fmb (FM Nothing)++minViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)+minViewWithKeyFMB E fk f = fail $ moduleName++".minView: empty map"+minViewWithKeyFMB (I i k (Just v) E m r)        kf f = return ((kf [k],v),f (I i k Nothing E m r))+minViewWithKeyFMB (I i k Nothing  E (FMB' E) r) kf f = error $ moduleName++".minViewWithKey: bug!"+minViewWithKeyFMB (I i k Nothing  E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:)) +	                                                (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))+minViewWithKeyFMB (I i k mv l m r)              kf f = minViewWithKeyFMB l kf+                                                        (\l' -> f (mkVBalancedFMB k mv l' m r))++minViewWithKey :: Monad m => FM k a -> m (([k],a),FM k a)+minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb)+minViewWithKey (FM Nothing fmb)  = minViewWithKeyFMB fmb id (FM Nothing)+++minElemFMB :: FMB k a -> a+minElemFMB E = error $ moduleName++".minElem: empty map"+minElemFMB (I i k (Just v) E m r)        = v+minElemFMB (I i k Nothing  E (FMB' m) r) = minElemFMB m+minElemFMB (I i k mv l m r)              = minElemFMB l++minElem (FM (Just v) fmb) = v+minElem (FM Nothing  fmb) = minElemFMB fmb+++minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a)+minElemWithKeyFMB kf E = error $ moduleName++".minElemWithKey: empty map"+minElemWithKeyFMB kf (I i k (Just v) E m r)        = (kf [k],v)+minElemWithKeyFMB kf (I i k Nothing  E (FMB' m) r) = minElemWithKeyFMB (kf . (k:)) m+minElemWithKeyFMB kf (I i k mv l m r)              = minElemWithKeyFMB kf l++minElemWithKey :: FM k a -> ([k],a)+minElemWithKey (FM (Just v) fmb) = ([],v)+minElemWithKey (FM Nothing  fmb) = minElemWithKeyFMB id fmb++deleteMin :: Ord k => FM k a -> FM k a+deleteMin = deleteMinUsingMinView++unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a+unsafeInsertMin = insert++maxViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)+maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f l)+--maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E))+maxViewFMB (I i k Nothing  l (FMB' E) E) f = error $ moduleName++".maxView: bug!"+maxViewFMB (I i k mv l (FMB' m) E)       f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E))+maxViewFMB (I i k mv l m r)              f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r'))+maxViewFMB E                             f = error $ moduleName++".maxView: bug!"++maxView :: Monad m => FM k a -> m (a, FM k a)+maxView (FM Nothing E)  = fail $ moduleName++".maxView: empty map"+maxView (FM (Just v) E) = return (v,FM Nothing E)+maxView (FM mv fmb)     = maxViewFMB fmb (FM mv)+++maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)+maxViewWithKeyFMB (I i k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l)+maxViewWithKeyFMB (I i k Nothing  l (FMB' E) E) kf f = error $ moduleName++".maxViewWithKey: bug!"+maxViewWithKeyFMB (I i k mv l (FMB' m) E)       kf f = maxViewWithKeyFMB m (kf . (k:))+                                                        (\m' -> f (I i k mv l (FMB' m') E))+maxViewWithKeyFMB (I i k mv l m r)              kf f = maxViewWithKeyFMB r kf+                                                        (\r' -> f (mkVBalancedFMB k mv l m r'))+maxViewWithKeyFMB E                             kf f = error $ moduleName++".maxViewWithKey: bug!"+++maxViewWithKey :: Monad m => FM k a -> m (([k],a), FM k a)+maxViewWithKey (FM Nothing E)  = fail $ moduleName++".maxViewWithKey: empty map"+maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E)+maxViewWithKey (FM mv fmb)     = maxViewWithKeyFMB fmb id (FM mv)++++maxElemFMB :: FMB k a -> a+maxElemFMB (I i k (Just v) l (FMB' E) E) = v+maxElemFMB (I i k Nothing  l (FMB' E) E) = error $ moduleName++".maxElem: bug!"+maxElemFMB (I i k mv l (FMB' m) E)       = maxElemFMB m+maxElemFMB (I i k mv l m r)              = maxElemFMB r+maxElemFMB E                             = error $ moduleName++".maxElem: bug!"++maxElem :: FM k a -> a+maxElem (FM (Just v) E) = v+maxElem (FM Nothing  E) = error $ moduleName++".maxElem: empty map"+maxElem (FM _ fmb)      = maxElemFMB fmb++maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a)+maxElemWithKeyFMB (I i k (Just v) l (FMB' E) E) kf = (kf [k],v)+maxElemWithKeyFMB (I i k Nothing  l (FMB' E) E) kf = error $ moduleName++".maxElemWithKey: bug!"+maxElemWithKeyFMB (I i k mv l (FMB' m) E)       kf = maxElemWithKeyFMB m (kf . (k:))+maxElemWithKeyFMB (I i k mv l m r)              kf = maxElemWithKeyFMB r kf+maxElemWithKeyFMB E                             kf = error $ moduleName++".maxElemWithKey: bug!"+++maxElemWithKey :: FM k a -> ([k],a)+maxElemWithKey (FM (Just v) E) = ([],v)+maxElemWithKey (FM Nothing E)  = error $ moduleName++".maxElemWithKey: empty map"+maxElemWithKey (FM _ fmb)      = maxElemWithKeyFMB fmb id+++deleteMax :: Ord k => FM k a -> FM k a+deleteMax = deleteMaxUsingMaxView++unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a+unsafeInsertMax = insert++unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a+unsafeFromOrdSeq = fromSeq++unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a+unsafeAppend = union++-- FIXME this doesn't respect the structural invariant... why??+{-+unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2)+unsafeAppend (FM Nothing  fmb1) (FM mv fmb2)      = FM mv       (appendFMB fmb1 fmb2)+unsafeAppend (FM (Just _) _) (FM (Just _) _)      = error $ moduleName++".unsafeAppend: bug!"+-}++filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a+filterL_FMB f k ks E = E+filterL_FMB f k ks (I i key mv l (FMB' m) r)+    | key < k   = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r)+    | key > k   = filterL_FMB f k ks l+    | otherwise = case ks of+                    []       -> f k mv l+                    (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E++filterLT :: Ord k => [k] -> FM k a -> FM k a+filterLT [] _               = FM Nothing E+filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> l) k ks fmb)++filterLE :: Ord k => [k] -> FM k a -> FM k a+filterLE [] (FM mv _)       = FM mv E+filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb)++++filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a+filterG_FMB f k ks E = E+filterG_FMB f k ks (I i key mv l (FMB' m) r)+    | key < k   = filterG_FMB f k ks r+    | key > k   = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r+    | otherwise = case ks of+                    []       -> f k mv m r+                    (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r++filterGT :: Ord k => [k] -> FM k a -> FM k a+filterGT []     (FM _  fmb) = FM Nothing fmb+filterGT (k:ks) (FM mv fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb)++filterGE :: Ord k => [k] -> FM k a -> FM k a+filterGE []     fm          = fm+filterGE (k:ks) (FM mv fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb)++--FIXME do better...+partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a)+partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm)++partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)+partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm)++partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)+partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm)++toOrdSeq = toOrdSeqUsingFoldrWithKey++-- instance declarations++instance Ord k  => A.AssocX (FM k) [k] where+  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; +   insertSeq = insertSeq; union = union; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; +   null = null; size = size; member = member; count = count; +   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; +   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;+   lookupAndDeleteAll = lookupAndDeleteAll;+   lookupWithDefault = lookupWithDefault; adjust = adjust; +   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;+   adjustAllOrInsert = adjustAllOrInsert;+   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; elements = elements;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName m = moduleName}++instance Ord k  => A.Assoc (FM k) [k] where+  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; +   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';+   filterWithKey = filterWithKey; +   partitionWithKey = partitionWithKey}++instance Ord k => A.FiniteMapX (FM k) [k] where+  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; +   insertWith  = insertWith; insertWithKey = insertWithKey; +   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; +   unionl = unionl; unionr = unionr; unionWith = unionWith; +   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; +   difference = difference; properSubset = properSubset; subset = subset;+   properSubmapBy = properSubmapBy; submapBy = submapBy;+   sameMapBy = sameMapBy}++instance Ord k => A.FiniteMap (FM k) [k] where+  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; +   intersectionWithKey = intersectionWithKey}++instance Ord k => A.OrdAssocX (FM k) [k] where+  {minView = minView; minElem = minElem; deleteMin = deleteMin;+   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;+   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;+   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;+   filterGE = filterGE;  partitionLT_GE = partitionLT_GE;+   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord k => A.OrdAssoc (FM k) [k] where+  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;+   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;+   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';+   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';+   toOrdSeq = toOrdSeq}++instance Ord k => A.OrdFiniteMapX (FM k) [k] +instance Ord k => A.OrdFiniteMap (FM k) [k]+++instance Ord k => Functor (FM k) where+  fmap = map++instance (Ord k, Show k, Show a) => Show (FM k a) where+  showsPrec = showsPrecUsingToList++instance (Ord k, Read k, Read a) => Read (FM k a) where+  readsPrec = readsPrecUsingFromList++instance (Ord k, Eq a) => Eq (FM k a) where+  (==) = sameMap++instance (Ord k, Ord a) => Ord (FM k a) where+  compare = compareUsingToOrdList++--+-- Test code follows+--++keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool+keyInvariantFMB p E = True+keyInvariantFMB p (I _ k _ l _ r)+  =    p k+    && keyInvariantFMB p l+    && keyInvariantFMB p r++actualSizeFMB :: FMB k a -> Int+actualSizeFMB E = 0+actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r++structuralInvariantFMB :: Ord k => FMB k a -> Bool+structuralInvariantFMB E = True+structuralInvariantFMB fmb@(I size k _ l (FMB' m) r)+  =    structuralInvariantFMB l+    && structuralInvariantFMB m+    && structuralInvariantFMB r+    && keyInvariantFMB (<k) l+    && keyInvariantFMB (>k) r+    && actualSizeFMB fmb == size+    && (sizel + sizer < 2+        || (sizel <= balance * sizer && sizer <= balance * sizel))+  where+      sizel = sizeFMB l+      sizer = sizeFMB r++structuralInvariant :: Ord k => FM k a -> Bool+structuralInvariant (FM k fmb) = structuralInvariantFMB fmb+++instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where+  arbitrary = do xs <- arbitrary+                 return (Prelude.foldr (uncurry insert) empty xs)++  coarbitrary (FM x fmb)  = coarbitrary_maybe x . coarbitrary_fmb fmb+++coarbitrary_maybe Nothing = variant 0+coarbitrary_maybe (Just x) = variant 1 . coarbitrary x++coarbitrary_fmb E = variant 0+coarbitrary_fmb (I _ k x l (FMB' m) r) =+	variant 1 . coarbitrary k . coarbitrary_maybe x .+        coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r++instance Ord k => Monoid (FM k a) where+   mempty  = empty+   mappend = union+   mconcat = unionSeq+
+ src/Data/Edison/Coll/Defaults.hs view
@@ -0,0 +1,244 @@+-- |+--   Module      :  Data.Edison.Coll.Defaults+--   Copyright   :  Copyright (c) 1998 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  internal (unstable)+--   Portability :  GHC / Hugs (MPTC and FD)+--+--   This module provides default implementations of many of the collection methods.  The functions+--   in this module are used to fill out collection implementations and are not intended to be+--   used directly by end users.++module Data.Edison.Coll.Defaults where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Control.Monad.Identity++import Data.Edison.Coll+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)++insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c+insertSeqUsingUnion xs c = union (fromSeq xs) c++insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c+insertSeqUsingFoldr xs c = S.foldr insert c xs++memberUsingFold :: Coll c a => c -> a -> Bool+memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h++countUsingMember :: SetX c a => a -> c -> Int+countUsingMember x xs = if member x xs then 1 else 0++lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a+lookupAllUsingLookupM x xs =+  case lookupM x xs of+    Nothing -> S.empty+    Just y  -> S.singleton y++deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c+deleteSeqUsingDelete xs c = S.foldr delete c xs++unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c+unionSeqUsingFoldl = S.foldl union empty++unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c+unionSeqUsingFoldl' = S.foldl' union empty++unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c+unionSeqUsingReduce = S.reducel union empty++fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c+fromSeqUsingFoldr = S.foldr insert empty++fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c+fromSeqUsingUnionSeq = unionList . S.foldl singleCons []+  where singleCons xs x = S.lcons (singleton x) xs++toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a+toSeqUsingFold = fold S.lcons S.empty++unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c+unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x)++toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a+toOrdSeqUsingFoldr = foldr S.lcons S.empty++unsafeFromOrdSeqUsingUnsafeInsertMin :: +    (OrdCollX c a,S.Sequence seq) => seq a -> c+unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty++disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool+disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys)+  where disj a@(x:xs) b@(y:ys) =+          case compare x y of+            LT -> disj xs b+            EQ -> False+            GT -> disj a ys+        disj _ _ = True++intersectWitnessUsingToOrdList ::+	(OrdColl c a, Monad m) => c -> c -> m (a,a)+intersectWitnessUsingToOrdList xs ys = witness (toOrdList xs) (toOrdList ys)+  where witness a@(x:xs) b@(y:ys) =+          case compare x y of+            LT -> witness xs b+            EQ -> return (x, y)+            GT -> witness a ys+	-- XXX+        witness _ _ = fail $ instanceName xs ++ ".intersect: failed"++lookupUsingLookupM :: Coll c a => a -> c -> a+lookupUsingLookupM x ys = runIdentity (lookupM x ys)++lookupUsingLookupAll :: Coll c a => a -> c -> a+lookupUsingLookupAll x ys =+  case lookupAll x ys of+    (y:_) -> y+    [] -> error $ instanceName ys ++ ".lookup: lookup failed"++lookupMUsingLookupAll :: (Coll c a, Monad m) => a -> c -> m a+lookupMUsingLookupAll x ys =+  case lookupAll x ys of+    (y:_) -> return y+    []    -> fail $ instanceName ys ++ ".lookupM: lookup failed"++lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a+lookupWithDefaultUsingLookupAll dflt x ys =+  case lookupAll x ys of+    (y:_) -> y+    [] -> dflt++lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a+lookupWithDefaultUsingLookupM dflt x ys =+  case lookupM x ys of+    Just y  -> y+    Nothing -> dflt++deleteMaxUsingMaxView :: OrdColl c a => c -> c+deleteMaxUsingMaxView c =+  case maxView c of+    Just (_,c') -> c'+    Nothing     -> c++fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c+fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty++insertUsingInsertWith :: Set c a => a -> c -> c+insertUsingInsertWith = insertWith (\x y -> x)++unionUsingUnionWith :: Set c a => c -> c -> c+unionUsingUnionWith = unionWith (\x y -> x)++filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c+filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList++partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c)+partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs)+  where (ys,zs) = L.partition p (toOrdList xs)++intersectionUsingIntersectionWith :: Set c a => c -> c -> c+intersectionUsingIntersectionWith = intersectionWith (\x y -> x)++differenceUsingOrdLists :: OrdSet c a => c -> c -> c+differenceUsingOrdLists xs ys = unsafeFromOrdList (diff (toOrdList xs) (toOrdList ys))+  where diff a@(x:xs) b@(y:ys) =+          case compare x y of+            LT -> x : diff xs b+            EQ -> diff xs ys+            GT -> diff a ys+        diff a _ = a++symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c+symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs)++properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool+properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys)++subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool+subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys)++properSubsetOnOrdLists [] [] = False+properSubsetOnOrdLists [] (_:_) = True+properSubsetOnOrdLists (_:_) [] = False+properSubsetOnOrdLists a@(x:xs) (y:ys) =+  case compare x y of+    LT -> False+    EQ -> properSubsetOnOrdLists xs ys+    GT -> subsetOnOrdLists a ys++subsetOnOrdLists [] _ = True+subsetOnOrdLists (_:_) [] = False+subsetOnOrdLists a@(x:xs) (y:ys) =+  case compare x y of+    LT -> False+    EQ -> subsetOnOrdLists xs ys+    GT -> subsetOnOrdLists a ys++insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c+insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs++unionlUsingUnionWith :: Set c a => c -> c -> c+unionlUsingUnionWith xs ys = unionWith (\x y -> x) xs ys++unionrUsingUnionWith :: Set c a => c -> c -> c+unionrUsingUnionWith xs ys = unionWith (\x y -> y) xs ys++unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c+unionWithUsingOrdLists c xs ys = unsafeFromOrdList (merge (toOrdList xs) (toOrdList ys))+  where merge a@(x:xs) b@(y:ys) =+          case compare x y of+            LT -> x : merge xs b+            EQ -> c x y : merge xs ys+            GT -> y : merge a ys+        merge a@(x:xs) [] = a+        merge [] b = b++unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c+unionSeqWithUsingReducer c = S.reducer (unionWith c) empty++intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c+intersectionWithUsingOrdLists c xs ys = unsafeFromOrdList (inter (toOrdList xs) (toOrdList ys))+  where inter a@(x:xs) b@(y:ys) =+          case compare x y of+            LT -> inter xs b+            EQ -> c x y : inter xs ys+            GT -> inter a ys+        inter _ _ = []+++unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout)+unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs++showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS+showsPrecUsingToList i xs rest+  | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]+  | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]++readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c+readsPrecUsingFromList i xs =+    let result = maybeParens p xs+        p xs = tokenMatch ((instanceName x)++".fromSeq") xs+                 >>= readsPrec 10+                 >>= \(l,rest) -> return (fromList l,rest)++        -- play games with the typechecker so we don't have to use+        -- extensions for scoped type variables+        ~[(x,_)] = result++    in result++compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering+compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)+ where+  cmp [] [] = EQ+  cmp [] _  = LT+  cmp _  [] = GT+  cmp (x:xs) (y:ys) =+      case compare x y of+         EQ -> cmp xs ys+         c -> c+
+ src/Data/Edison/Coll/EnumSet.hs view
@@ -0,0 +1,798 @@+-----------------------------------------------------------------------------+-- |+--   Module      :  Data.Edison.Coll.EnumSet+--   Copyright   :  (c) David F. Place 2006+--   License     :  BSD+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+-- An efficient implementation of sets over small enumerations.+-- The implementation of 'EnumSet' is based on bit-wise operations.+--+-- For this implementation to work as expected at type @A@, there are a number+-- of preconditions on the @Eq@, @Enum@ and @Ord@ instances.+--+-- The @Enum A@ instance must create a bijection between the elements of type @A@ and+-- a finite subset of the naturals [0,1,2,3....].  As a corollary we must have:+--+-- > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y+--+-- Also, the number of distinct elements of @A@ must be less than or equal+-- to the number of bits in @Word@.+--+-- The @Enum A@ instance must be consistent with the @Eq A@ instance. +-- That is, we must have:+--+-- > forall x y::A, x == y <==> toEnum x == toEnum y +--+-- Additionally, for operations that require an @Ord A@ context, we require that+-- toEnum be monotonic with respect to comparison.  That is, we must have:+--+-- > forall x y::A, x < y <==> toEnum x < toEnum y+--+-- Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if+-- the enumerated type has sufficently few constructors.++{-+Copyright (c) 2006, David F. Place+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 David F. Place nor the names of its+  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+OWNER 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.+-} ++module Data.Edison.Coll.EnumSet (+            -- * Set type+            Set          ++	    -- * CollX operations+            , empty+            , singleton+            , fromSeq+            , insert+            , insertSeq+            , union+            , unionSeq+            , delete+            , deleteAll+            , deleteSeq+            , null+            , size+            , member+            , count+            , strict++            -- * OrdCollX operations+            , deleteMin+            , deleteMax+            , unsafeInsertMin+            , unsafeInsertMax+            , unsafeFromOrdSeq+            , unsafeAppend+            , filterLT+            , filterLE+            , filterGT+            , filterGE+            , partitionLT_GE+            , partitionLE_GT+            , partitionLT_GT++            -- * SetX operations+            , intersection+            , difference+            , symmetricDifference+            , properSubset+            , subset++            -- * Coll operations+            , toSeq+            , lookup+            , lookupM+            , lookupAll+            , lookupWithDefault+            , fold, fold', fold1, fold1'+            , filter+            , partition+            , strictWith++            -- * OrdColl operations+            , minView+            , minElem+            , maxView+            , maxElem+            , foldr, foldr', foldl, foldl'+            , foldr1, foldr1', foldl1, foldl1'+            , toOrdSeq+            , unsafeMapMonotonic++            -- * Set operations+            , fromSeqWith+            , insertWith+            , insertSeqWith+            , unionl+            , unionr+            , unionWith+            , unionSeqWith+            , intersectionWith++            -- * Bonus operations+            , map+            , setCoerce+            , complement+            , toBits+            , fromBits++            -- * Documenation+            , moduleName+)  where++import qualified Prelude+import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1)+import qualified Data.Bits as Bits+import Data.Bits hiding (complement)+import Data.Word+import Data.Monoid (Monoid(..))+import Data.Array++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Coll.Defaults+import Test.QuickCheck hiding (check)++moduleName = "Data.Edison.Coll.EnumSet"++{--------------------------------------------------------------------+  Sets are bit strings of width wordLength.+--------------------------------------------------------------------}+-- | A set of values @a@ implemented as bitwise operations.  Useful+-- for members of class Enum with no more elements than there are bits +-- in @Word@.+newtype Set a = Set Word deriving (Eq)++wordLength :: Int+wordLength = bitSize (0::Word)++check :: String -> Int -> Int +check msg x  +    | x < wordLength = x+    | otherwise = error $ "EnumSet."++msg++": element beyond word size."+++-- no interesting structural invariants+structuralInvariant :: Set a -> Bool+structuralInvariant = const True+++----------------------------------------------------+-- bit twiddly magic++countBits :: Word -> Int+countBits w = w `seq` bitcount 0 w++bitcount :: Int -> Word -> Int+bitcount a 0 = a+bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))++-- stolen from http://aggregate.org/MAGIC/+lsb :: Word -> Int+lsb x = countBits ((x-1) .&. (Bits.complement x))++msb :: Word -> Int+msb x0 = let+     x1 = x0 .|. (x0 `shiftR` 1)+     x2 = x1 .|. (x1 `shiftR` 2)+     x3 = x2 .|. (x2 `shiftR` 4)+     x4 = x3 .|. (x3 `shiftR` 8)+     x5 = x4 .|. (x4 `shiftR` 16)+     in countBits x5 - 1+++lowMask :: Int -> Word+lowMask x = bit x - 1++highMask :: Int -> Word+highMask x = Bits.complement (lowMask x)++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is this the empty set?+null :: Set a -> Bool+null (Set 0) = True+null _       = False++-- | /O(1)/. The number of elements in the set.+size :: Set a -> Int+size (Set w) = countBits w++-- | /O(1)/. Is the element in the set?+member :: (Eq a, Enum a) => a -> Set a -> Bool+member x (Set w) = testBit w $ fromEnum x++count :: (Eq a, Enum a) => a -> Set a -> Int+count = countUsingMember++lookup :: (Eq a, Enum a) => a -> Set a -> a+lookup = lookupUsingLookupAll++lookupM :: (Eq a, Enum a, Monad m) => a -> Set a -> m a+lookupM x s+   | member x s = return x+   | otherwise  = fail (moduleName++".lookupM: lookup failed")++lookupAll  :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a+lookupAll = lookupAllUsingLookupM++lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a+lookupWithDefault = lookupWithDefaultUsingLookupM++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: Set a+empty = Set 0++-- | /O(1)/. Create a singleton set.+singleton :: (Eq a, Enum a) => a -> Set a+singleton x =+    Set $ setBit 0 $ check "singleton" $ fromEnum x++{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(1)/. Insert an element in a set.+-- If the set already contains an element equal to the given value,+-- it is replaced with the new value.+insert :: (Eq a, Enum a) => a -> Set a -> Set a+insert x (Set w) =+    Set $ setBit w $ check "insert" $ fromEnum x++-- given the preconditions, we can just ignore the combining function+insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a+insertWith f x (Set w) =+    Set $ setBit w $ check "insertWith" $ fromEnum x++-- | /O(1)/. Delete an element from a set.+delete :: (Eq a, Enum a) => a -> Set a -> Set a+delete x (Set w) = +    Set $ clearBit w $ fromEnum x++deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a+deleteAll = delete++deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a+deleteSeq = deleteSeqUsingDelete++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(1)/. Is this a proper subset? (ie. a subset but not equal).+properSubset :: Set a -> Set a -> Bool+properSubset x y = (x /= y) && (subset x y)++-- | /O(1)/. Is this a subset?+-- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@.+subset :: Set a -> Set a -> Bool+subset x y = (x `union` y) == y++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- | /O(1)/. The minimal element of a set.+minElem :: (Enum a) => Set a -> a+minElem (Set w) +   | w == 0    = error $ moduleName++".minElem: empty set"+   | otherwise = toEnum $ lsb w++-- | /O(1)/. The maximal element of a set.+maxElem :: (Enum a) => Set a -> a+maxElem (Set w)+   | w == 0    = error $ moduleName++".maxElem: empty set"+   | otherwise = toEnum $ msb w++-- | /O(1)/. Delete the minimal element.+deleteMin :: (Enum a) => Set a -> Set a+deleteMin (Set w) +   | w == 0    = empty+   | otherwise = Set $ clearBit w $ lsb w++-- | /O(1)/. Delete the maximal element.+deleteMax :: (Enum a) => Set a -> Set a+deleteMax (Set w)+   | w == 0    = empty+   | otherwise = Set $ clearBit w $ msb w++minView :: (Enum a, Monad m) => Set a -> m (a, Set a)+minView (Set w)+   | w == 0    = fail (moduleName++".minView: empty set")+   | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i)++maxView :: (Enum a, Monad m) => Set a -> m (a, Set a)+maxView (Set w)+   | w == 0    = fail (moduleName++".maxView: empty set")+   | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i)++unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a+unsafeInsertMin = insert++unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a+unsafeInsertMax = insert++unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a+unsafeAppend = union++unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a+unsafeFromOrdSeq = fromSeq++filterLT :: (Ord a, Enum a) => a -> Set a -> Set a+filterLT x (Set w) = Set (w .&. lowMask (fromEnum x))++filterLE :: (Ord a, Enum a) => a -> Set a -> Set a+filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1))++filterGT :: (Ord a, Enum a) => a -> Set a -> Set a+filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1))++filterGE :: (Ord a, Enum a) => a -> Set a -> Set a+filterGE x (Set w) = Set (w .&. highMask (fromEnum x))++partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)+partitionLT_GE x s = (filterLT x s,filterGE x s)++partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)+partitionLE_GT x s = (filterLE x s,filterGT x s)++partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)+partitionLT_GT x s = (filterLT x s,filterGT x s)+++{--------------------------------------------------------------------+  Union. +--------------------------------------------------------------------}+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).+unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a+unionSeq = unionSeqUsingFoldl'++-- | /O(1)/. The union of two sets.+union :: Set a -> Set a -> Set a+union (Set x) (Set y) = Set $ x .|. y++unionl :: Set a -> Set a -> Set a+unionl = union++unionr :: Set a -> Set a -> Set a+unionr = union++-- given the preconditions, we can just ignore the combining function+unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a+unionWith f = union++unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a+unionSeqWith f = unionSeq++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(1)/. Difference of two sets. +difference :: Set a -> Set a -> Set a+difference (Set x) (Set y) = Set $ (x .|. y) `xor` y++symmetricDifference :: Set a -> Set a -> Set a+symmetricDifference (Set x) (Set y) = Set $ x `xor` y++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(1)/. The intersection of two sets.+intersection :: Set a -> Set a -> Set a+intersection (Set x) (Set y) = Set $ x .&. y++intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a+intersectionWith f = intersection++{--------------------------------------------------------------------+  Complement+--------------------------------------------------------------------}+-- | /O(1)/. The complement of a set with its universe set. @complement@ can be used+--   with bounded types for which the universe set+--   will be automatically created.+complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a+complement x = symmetricDifference u x+    where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a+filter p (Set w) = Set $ foldlBits' f 0 w+    where +      f z i +        | p $ toEnum i = setBit z i+        | otherwise = z++-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+-- See also 'split'.+partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a)+partition p (Set w) = (Set yay,Set nay)+    where +      (yay,nay) = foldlBits' f (0,0) w+      f (x,y) i+          | p $ toEnum i = (setBit x i,y)+          | otherwise    = (x,setBit y i)+++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}+-- | /O(n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+-- +-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@+map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b+map f0 (Set w) = Set $ foldlBits' f 0 w+    where+      f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i)++unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a+unsafeMapMonotonic = map++-- | /O(1)/ Changes the type of the elements in the set without changing+--   the representation.  Equivalant to @map (toEnum . fromEnum)@, and+--   to @(fromBits . toBits)@.  This method is operationally a no-op.+setCoerce :: (Enum a, Enum b) => Set a -> Set b+setCoerce (Set w) = Set w++-- | /O(1)/ Get the underlying bit-encoded representation.+--   This method is operationally a no-op.+toBits :: Set a -> Word+toBits (Set w) = w++-- | /O(1)/ Create an EnumSet from a bit-encoded representation.+--   This method is operationally a no-op.+fromBits :: Word -> Set a+fromBits w = Set w+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}++fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c+fold f z (Set w) = foldrBits folder z w+  where folder i z = f (toEnum i) z++fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c+fold' f z (Set w) = foldrBits' folder z w+  where folder i z = f (toEnum i) z++fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a+fold1 f (Set 0) = error (moduleName++".fold1: empty set")+fold1 f (Set w) = foldrBits folder (toEnum max) (clearBit w max)+    where+      max = msb w+      folder i z = f (toEnum i) z++fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a+fold1' f (Set 0) = error (moduleName++".fold1': empty set")+fold1' f (Set w) = foldrBits folder (toEnum max) (clearBit w max)+    where+      max = msb w+      folder i z = f (toEnum i) z++foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b+foldr f z (Set w) = foldrBits folder z w+  where folder i z = f (toEnum i) z++foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b+foldr' f z (Set w) = foldrBits' folder z w+  where folder i z = f (toEnum i) z++foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a+foldr1 f (Set 0) = error (moduleName++".foldr1: empty set")+foldr1 f (Set w) = foldrBits folder (toEnum max) (clearBit w max)+    where+      max = msb w+      folder i z = f (toEnum i) z++foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a+foldr1' f (Set 0) = error (moduleName++".foldr1': empty set")+foldr1' f (Set w) = foldrBits folder (toEnum max) (clearBit w max)+    where+      max = msb w+      folder i z = f (toEnum i) z++foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c+foldl f z (Set w) = foldlBits folder z w+  where folder z i = f z (toEnum i)++foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c+foldl' f z (Set w) = foldlBits' folder z w+  where folder z i = f z (toEnum i)++foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a+foldl1 f (Set 0) = error (moduleName++".foldl1: empty set")+foldl1 f (Set w) = foldlBits folder (toEnum min) (clearBit w min)+  where+    min = lsb w+    folder z i = f z (toEnum i)++foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a+foldl1' f (Set 0) = error (moduleName++".foldl1': empty set")+foldl1' f (Set w) = foldlBits' folder (toEnum min) (clearBit w min)+  where+    min = lsb w+    folder z i = f z (toEnum i)++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a+fromSeq xs = Set $ S.fold' f 0 xs+  where f x z = setBit z $ check "fromSeq" $ fromEnum x++fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a+fromOrdSeq = fromSeq++insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a+insertSeq = insertSeqUsingUnion++-- given the preconditions, we can just ignore the combining function+insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a+insertSeqWith f = insertSeq++toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a+toSeq (Set w) = foldrBits f S.empty w+  where f i z = S.lcons (toEnum i) z++toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a+toOrdSeq = toSeq++fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a+fromSeqWith = fromSeqWithUsingInsertWith +++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+{-+splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a)+splitMember x (Set w) = (Set lesser,isMember,Set greater)+    where+      (lesser,isMember,greater) = foldrBits f (0,False,0) w+      f i (lesser,isMember,greater) =+        case compare (toEnum i) x of+          GT -> (lesser,isMember,setBit greater i)+          LT -> (setBit lesser i,isMember,greater)+          EQ -> (lesser,True,greater)+-}+++{----------------------------------------------------------------+  Strictness enhancement+----------------------------------------------------------------}++strict :: Set a -> Set a+strict s@(Set w) = w `seq` s++strictWith :: (a -> b) -> Set a -> Set a+strictWith f s@(Set w) = w `seq` s++{--------------------------------------------------------------------+  Utility functions. +--------------------------------------------------------------------}++foldrBits :: (Int -> a -> a) -> a -> Word -> a+foldrBits f z w = foldrBits_aux f z 0 w++foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a+foldrBits_aux f z i 0 = z+foldrBits_aux f z i w+   | i `seq` w `seq` False = undefined+   | otherwise =+   case w .&. 0x0F of+     0x00 -> a+     0x01 -> f i $ a+     0x02 -> f (i+1) $ a+     0x03 -> f i $ f (i+1) $ a+     0x04 -> f (i+2) $ a+     0x05 -> f i $ f (i+2) $ a+     0x06 -> f (i+1) $ f (i+2) $ a+     0x07 -> f i $ f (i+1) $ f (i+2) $ a+     0x08 -> f (i+3) $ a+     0x09 -> f i $ f (i+3) $ a+     0x0A -> f (i+1) $ f (i+3) $ a+     0x0B -> f i $ f (i+1) $ f (i+3) $ a+     0x0C -> f (i+2) $ f (i+3) $ a+     0x0D -> f i $ f (i+2) $ f (i+3) $ a+     0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a+     0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a+     _ -> error "bug in foldrBits_aux"++ where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4)+++foldrBits' :: (Int -> a -> a) -> a -> Word -> a+foldrBits' f z w = foldrBits_aux' f z 0 w++foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a+foldrBits_aux' f z i 0 = z+foldrBits_aux' f z i w+   | i `seq` w `seq` False = undefined+   | otherwise =+   case w .&. 0x0F of+     0x00 -> a+     0x01 -> f i $! a+     0x02 -> f (i+1) $! a+     0x03 -> f i $! f (i+1) $! a+     0x04 -> f (i+2) $! a+     0x05 -> f i $! f (i+2) $! a+     0x06 -> f (i+1) $! f (i+2) $! a+     0x07 -> f i $! f (i+1) $! f (i+2) $! a+     0x08 -> f (i+3) $! a+     0x09 -> f i $! f (i+3) $! a+     0x0A -> f (i+1) $! f (i+3) $! a+     0x0B -> f i $! f (i+1) $! f (i+3) $! a+     0x0C -> f (i+2) $! f (i+3) $! a+     0x0D -> f i $! f (i+2) $! f (i+3) $! a+     0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a+     0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a+     _ -> error "bug in foldrBits_aux'"++ where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4)+++foldlBits :: (a -> Int -> a) -> a -> Word -> a+foldlBits f z w = foldlBits_aux f z 0 w++foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a+foldlBits_aux f z i 0 = z+foldlBits_aux f z i w+   | i `seq` w `seq` False = undefined+   | otherwise =+   case w .&. 0x0F of+     0x00 -> a $ z+     0x01 -> a $ f z i+     0x02 -> a $ f z (i+1)+     0x03 -> a $ f (f z i) (i+1)+     0x04 -> a $ f z (i+2)+     0x05 -> a $ f (f z i) (i+2)+     0x06 -> a $ f (f z (i+1)) (i+2)+     0x07 -> a $ f (f (f z i) (i+1)) (i+2)+     0x08 -> a $ f z (i+3)+     0x09 -> a $ f (f z i) (i+3)+     0x0A -> a $ f (f z (i+1)) (i+3)+     0x0B -> a $ f (f (f z i) (i+1)) (i+3)+     0x0C -> a $ f (f z (i+2)) (i+3)+     0x0D -> a $ f (f (f z i) (i+2)) (i+3)+     0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3)+     0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3)+     _ -> error "bug in foldlBits_aux"++ where a z = foldlBits_aux f z (i+4) (Bits.shiftR w 4)++foldlBits' :: (a -> Int -> a) -> a -> Word -> a+foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w++foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a+foldlBits_aux' f z i 0 = z+foldlBits_aux' f z i w+   | i `seq` w `seq` False = undefined+   | otherwise =+   case w .&. 0x0F of+     0x00 -> a $! z+     0x01 -> a $! f z i+     0x02 -> a $! f z (i+1)+     0x03 -> a $! f (f z i) (i+1)+     0x04 -> a $! f z (i+2)+     0x05 -> a $! f (f z i) (i+2)+     0x06 -> a $! f (f z (i+1)) (i+2)+     0x07 -> a $! f (f (f z i) (i+1)) (i+2)+     0x08 -> a $! f z (i+3)+     0x09 -> a $! f (f z i) (i+3)+     0x0A -> a $! f (f z (i+1)) (i+3)+     0x0B -> a $! f (f (f z i) (i+1)) (i+3)+     0x0C -> a $! f (f z (i+2)) (i+3)+     0x0D -> a $! f (f (f z i) (i+2)) (i+3)+     0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3)+     0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3)+     _ -> error "bug in foldlBits_aux"++ where a z = foldlBits_aux' f z (i+4) (Bits.shiftR w 4)++instance (Eq a, Enum a) => C.CollX (Set a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance (Ord a, Enum a) => C.OrdCollX (Set a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance (Eq a, Enum a) => C.SetX (Set a) a where+  {intersection = intersection; difference = difference;+   symmetricDifference = symmetricDifference;+   properSubset = properSubset; subset = subset}++instance (Eq a, Enum a) => C.Coll (Set a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance (Ord a, Enum a) => C.OrdColl (Set a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; +   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic}++instance (Eq a, Enum a) => C.Set (Set a) a where+  {fromSeqWith = fromSeqWith; insertWith = insertWith; +   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;+   unionWith = unionWith; unionSeqWith = unionSeqWith;+   intersectionWith = intersectionWith}++instance (Ord a, Enum a) => C.OrdSetX (Set a) a+instance (Ord a, Enum a) => C.OrdSet (Set a) a++instance (Eq a, Enum a, Show a) => Show (Set a) where+   showsPrec = showsPrecUsingToList++instance (Eq a, Enum a, Read a) => Read (Set a) where+   readsPrec = readsPrecUsingFromList++instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = do (w::Int) <- arbitrary+                 return (Set (fromIntegral w))++  coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int)++instance (Eq a, Enum a) => Monoid (Set a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a, Enum a) => Ord (Set a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/LazyPairingHeap.hs view
@@ -0,0 +1,562 @@+-- |+--   Module      :  Data.Edison.Coll.LazyPairingHeap+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Lazy Paring Heaps+--+--   /References:/+--+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998.+--   Section 6.5.++module Data.Edison.Coll.LazyPairingHeap (+    -- * Type of pairing heaps+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',+    fold1, fold1', filter, partition, strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,+    unsafeMapMonotonic,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..),+				   Coll(..), OrdColl(..), toOrdList )+import qualified Data.Edison.Seq as S+import Data.Edison.Coll.Defaults+import Data.List(sort)+import Data.Monoid+import Control.Monad+import Test.QuickCheck++moduleName = "Data.Edison.Coll.LazyPairingHeap"+++data Heap a = E +            | H1 a (Heap a)+            | H2 a !(Heap a) (Heap a)+++-- Invariants: +--   * left child of H2 not empty+structuralInvariant :: Heap a -> Bool+structuralInvariant E = True+structuralInvariant (H1 _ h) = structuralInvariant h+structuralInvariant (H2 _ E _) = False+structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r++-- second arg is not empty+-- not used!+link E h = h+link (H1 x b) a = H2 x a b+link (H2 x a b) a' = H1 x (union (union a a') b)++makeH2 x E xs = H1 x xs+makeH2 x h xs = H2 x h xs++empty :: Heap a+empty = E++singleton :: a -> Heap a+singleton x = H1 x E++insert :: Ord a => a -> Heap a -> Heap a+insert x E = H1 x E+insert x h@(H1 y b)+  | x <= y    = H1 x h+  | otherwise = H2 y (H1 x E) b+insert x h@(H2 y a b)+  | x <= y    = H1 x h+  | otherwise = H1 y (union (insert x a) b)++union :: Ord a => Heap a -> Heap a -> Heap a+union E h = h+union hx@(H1 x xs) E = hx+union hx@(H1 x xs) hy@(H1 y ys)+  | x <= y    = H2 x hy xs+  | otherwise = H2 y hx ys+union hx@(H1 x xs) hy@(H2 y a ys)+  | x <= y    = H2 x hy xs+  | otherwise = H1 y (union (union hx a) ys)+union hx@(H2 x a xs) E = hx+union hx@(H2 x a xs) hy@(H1 y ys)+  | x <= y    = H1 x (union (union hy a) xs)+  | otherwise = H2 y hx ys+union hx@(H2 x a xs) hy@(H2 y b ys)+  | x <= y    = H1 x (union (union hy a) xs)+  | otherwise = H1 y (union (union hx b) ys)++delete :: Ord a => a -> Heap a -> Heap a+delete y h = case del h of Just h' -> h'+                           Nothing -> h+  where del E = Nothing+        del (H1 x xs) =+          case compare x y of+            LT -> case del xs of+                    Just xs -> Just (H1 x xs)+                    Nothing -> Nothing+            EQ -> Just xs+            GT -> Nothing+        del (H2 x a xs) =+          case compare x y of+            LT -> case del a of+                    Just a' -> Just (makeH2 x a' xs)+                    Nothing -> case del xs of+                                 Just xs' -> Just (H2 x a xs')+                                 Nothing -> Nothing+            EQ -> Just (union a xs)+            GT -> Nothing++deleteAll :: Ord a => a -> Heap a -> Heap a+deleteAll y E = E+deleteAll y h@(H1 x xs) =+  case compare x y of+    LT -> H1 x (deleteAll y xs)+    EQ -> deleteAll y xs+    GT -> h+deleteAll y h@(H2 x a xs) =+  case compare x y of+    LT -> makeH2 x (deleteAll y a) (deleteAll y xs)+    EQ -> union (deleteAll y a) (deleteAll y xs)+    GT -> h++deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+deleteSeq = delList . sort . S.toList+  where delList [] h = h+        delList (y:ys) h = del y ys h++        del y ys E = E+        del y ys h@(H1 x xs) =+          case compare x y of+            LT -> H1 x (del y ys xs)+            EQ -> delList ys xs+            GT -> delList ys h+        del y ys h@(H2 x a xs) =+          case compare x y of+            LT -> H1 x (del y ys (union a xs))+            EQ -> delList ys (union a xs)+            GT -> delList ys h+        {-+           could write the two GT cases as+             delList (dropWhile (< x) ys) h+           but this is only a win if we expect many of the ys+           to be missing from the tree.  However, we expect most+           of the ys to be present.+        -}++null :: Heap a -> Bool+null E = True+null _ = False++size :: Heap a -> Int+size E = 0+size (H1 x xs) = 1 + size xs+size (H2 x h xs) = 1 + size h + size xs++member :: Ord a => a -> Heap a -> Bool+member x E = False+member x (H1 y ys) =+  case compare x y of+    LT -> False+    EQ -> True+    GT -> member x ys+member x (H2 y h ys) =+  case compare x y of+    LT -> False+    EQ -> True+    GT -> member x h || member x ys++count :: Ord a => a -> Heap a -> Int+count x E = 0+count x (H1 y ys) =+  case compare x y of+    LT -> 0+    EQ -> 1 + count x ys+    GT -> count x ys+count x (H2 y h ys) =+  case compare x y of+    LT -> 0+    EQ -> 1 + count x h + count x ys+    GT -> count x h + count x ys++deleteMin :: Ord a => Heap a -> Heap a+deleteMin E = E+deleteMin (H1 x xs) = xs+deleteMin (H2 x h xs) = union h xs++unsafeInsertMin :: Ord a => a -> Heap a -> Heap a+unsafeInsertMin = H1++unsafeInsertMax :: Ord a => a -> Heap a -> Heap a+unsafeInsertMax x E = H1 x E+unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys+unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys)++unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a+unsafeAppend h E = h+unsafeAppend E h = h+unsafeAppend (H1 x xs) h = H2 x h xs+unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs)++filterLT :: Ord a => a -> Heap a -> Heap a+filterLT y E = E+filterLT y (H1 x xs)+  | x < y = H1 x (filterLT y xs)+  | otherwise = E+filterLT y (H2 x h xs)+  | x < y = makeH2 x (filterLT y h) (filterLT y xs)+  | otherwise = E++filterLE :: Ord a => a -> Heap a -> Heap a+filterLE y E = E+filterLE y (H1 x xs)+  | x <= y = H1 x (filterLE y xs)+  | otherwise = E+filterLE y (H2 x h xs)+  | x <= y = makeH2 x (filterLE y h) (filterLE y xs)+  | otherwise = E++filterGT :: Ord a => a -> Heap a -> Heap a+filterGT y h = fgt h E+  where fgt E rest = rest+        fgt h@(H1 x xs) rest+          | x > y = union h rest+          | otherwise = fgt xs rest+        fgt h@(H2 x a xs) rest+          | x > y = union h rest+          | otherwise = fgt a (fgt xs rest)++filterGE :: Ord a => a -> Heap a -> Heap a+filterGE y h = fge h E+  where fge E rest = rest+        fge h@(H1 x xs) rest+          | x >= y = union h rest+          | otherwise = fge xs rest+        fge h@(H2 x a xs) rest+          | x >= y = union h rest+          | otherwise = fge a (fge xs rest)++partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GE y E = (E,E)+partitionLT_GE y h@(H1 x xs)+  | x < y = let (xs',xs'') = partitionLT_GE y xs+            in (H1 x xs',xs'')+  | otherwise = (E, h)+partitionLT_GE y h@(H2 x a xs)+  | x < y = let (a',a'') = partitionLT_GE y a+                (xs',xs'') = partitionLT_GE y xs+            in (makeH2 x a' xs',union a'' xs'')+  | otherwise = (E, h)++partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLE_GT y E = (E,E)+partitionLE_GT y h@(H1 x xs)+  | x <= y = let (xs',xs'') = partitionLE_GT y xs+             in (H1 x xs',xs'')+  | otherwise = (E, h)+partitionLE_GT y h@(H2 x a xs)+  | x <= y = let (a',a'') = partitionLE_GT y a+                 (xs',xs'') = partitionLE_GT y xs+             in (makeH2 x a' xs',union a'' xs'')+  | otherwise = (E, h)++partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GT y E = (E,E)+partitionLT_GT y h@(H1 x xs) =+  case compare x y of+    LT -> let (xs',xs'') = partitionLT_GT y xs+          in (H1 x xs',xs'')+    EQ -> (E, filterGT y xs)+    GT -> (E, h)+partitionLT_GT y h@(H2 x a xs) =+  case compare x y of+    LT -> let (a',a'') = partitionLT_GT y a+              (xs',xs'') = partitionLT_GT y xs+          in (makeH2 x a' xs',union a'' xs'')+    EQ -> (E, union (filterGT y a) (filterGT y xs))+    GT -> (E, h)++toSeq :: S.Sequence seq => Heap a -> seq a+toSeq h = tol h S.empty+  where tol E rest = rest+        tol (H1 x xs) rest = S.lcons x (tol xs rest)+        tol (H2 x h xs) rest = S.lcons x (tol h (tol xs rest))++fold :: (a -> b -> b) -> b -> Heap a -> b+fold f c E = c+fold f c (H1 x xs) = f x (fold f c xs)+fold f c (H2 x h xs) = f x (fold f (fold f c xs) h)++fold' :: (a -> b -> b) -> b -> Heap a -> b+fold' f c E = c+fold' f c (H1 x xs)   = c `seq` f x $! (fold' f c xs)+fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h)+++fold1 :: (a -> a -> a) -> Heap a -> a+fold1 f E = error "LazyPairingHeap.fold1: empty heap"+fold1 f (H1 x xs) = fold f x xs+fold1 f (H2 x h xs) = fold f (fold f x xs) h++fold1' :: (a -> a -> a) -> Heap a -> a+fold1' f E = error "LazyPairingHeap.fold1': empty heap"+fold1' f (H1 x xs)   = fold' f x xs+fold1' f (H2 x h xs) = fold' f (fold' f x xs) h+++filter :: Ord a => (a -> Bool) -> Heap a -> Heap a+filter p E = E+filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs+filter p (H2 x h xs) =+  if p x then makeH2 x (filter p h) (filter p xs)+         else union (filter p h) (filter p xs)++partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)+partition p E = (E, E)+partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'')+    where (xs',xs'') = partition p xs+partition p (H2 x h xs) =+  if p x then (makeH2 x h' xs', union h'' xs'')+         else (union h' xs', makeH2 x h'' xs'')+    where (h',h'') = partition p h+          (xs',xs'') = partition p xs++lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a+lookupAll y h = look h S.empty+  where look E rest = rest+        look (H1 x xs) rest =+          case compare x y of+            LT -> look xs rest+            EQ -> S.lcons x (look xs rest)+            GT -> rest+        look (H2 x h xs) rest =+          case compare x y of+            LT -> look h (look xs rest)+            EQ -> S.lcons x (look h (look xs rest))+            GT -> rest++minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+minView E = fail "LazyPairingHeap.minView: empty heap"+minView (H1 x xs) = return (x,xs)+minView (H2 x h xs) = return (x,union h xs)++minElem :: Heap a -> a+minElem E = error "LazyPairingHeap.minElem: empty heap"+minElem (H1 x xs) = x+minElem (H2 x h xs) = x++maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+maxView E = fail "LazyPairingHeap.maxView: empty heap"+maxView xs = return (y,xs')+  where (xs', y) = maxView' xs++-- not exported+maxView' (H1 x E) = (E, x)+maxView' (H1 x xs) = (H1 x xs', y)+  where (xs', y) = maxView' xs+maxView' (H2 x a E) = (H1 x a', y)+  where (a', y) = maxView' a+maxView' (H2 x a xs) = +    if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z)+  where (a', y) = maxView' a+        (xs', z) = maxView' xs+maxView' E = error "LazyPairingHeap.maxView': bug!"++maxElem :: Ord a => Heap a -> a+maxElem E = error "LazyPairingHeap.maxElem: empty heap"+maxElem (H1 x E) = x+maxElem (H1 x xs) = maxElem xs+maxElem (H2 x h E) = maxElem h+maxElem (H2 x h xs) = max (maxElem h) (maxElem xs)++foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr f c E = c+foldr f c (H1 x xs) = f x (foldr f c xs)+foldr f c (H2 x h xs) = f x (foldr f c (union h xs))++foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr' f c E = c+foldr' f c (H1 x xs)   = c `seq` f x $! (foldr' f c xs)+foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs))++foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl f c E = c+foldl f c (H1 x xs) = foldl f (f c x) xs+foldl f c (H2 x h xs) = foldl f (f c x) (union h xs)++foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl' f c E = c+foldl' f c (H1 x xs)   = c `seq` foldl' f (f c x) xs+foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs)++foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1 f E = error "LazyPairingHeap.foldr1: empty heap"+foldr1 f (H1 x E) = x+foldr1 f (H1 x xs) = f x (foldr1 f xs)+foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs))++foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1' f E = error "LazyPairingHeap.foldr1': empty heap"+foldr1' f (H1 x E)    = x+foldr1' f (H1 x xs)   = f x $! (foldr1' f xs)+foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs))++foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1 f E = error "LazyPairingHeap.foldl1: empty heap"+foldl1 f (H1 x xs) = foldl f x xs+foldl1 f (H2 x h xs) = foldl f x (union h xs)++foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1' f E = error "LazyPairingHeap.foldl1': empty heap"+foldl1' f (H1 x xs)   = foldl' f x xs+foldl1' f (H2 x h xs) = foldl' f x (union h xs)++unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b+unsafeMapMonotonic = mapm+  where mapm f E = E+        mapm f (H1 x xs) = H1 (f x) (mapm f xs)+        mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs)+++strict :: Heap a -> Heap a+strict h@E = h+strict h@(H1 x xs) = strict xs `seq` h+strict h@(H2 x h' xs) = strict h' `seq` strict xs `seq` h++strictWith :: (a -> b) -> Heap a -> Heap a+strictWith f h@E = h+strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h+strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h+++-- the remaining functions all use default definitions++fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+fromSeq = fromSeqUsingFoldr++insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+insertSeq = insertSeqUsingFoldr++unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a+unionSeq = unionSeqUsingFoldl++unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin++deleteMax :: Ord a => Heap a -> Heap a+deleteMax = deleteMaxUsingMaxView++lookup :: Ord a => a -> Heap a -> a+lookup = lookupUsingLookupAll++lookupM :: (Ord a, Monad m) => a -> Heap a -> m a+lookupM = lookupMUsingLookupAll++lookupWithDefault :: Ord a => a -> a -> Heap a -> a+lookupWithDefault = lookupWithDefaultUsingLookupAll++toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a+toOrdSeq = toOrdSeqUsingFoldr++-- instance declarations++instance Ord a => C.CollX (Heap a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Heap a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Heap a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance Ord a => C.OrdColl (Heap a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; +   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;+   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}++instance Ord a => Eq (Heap a) where+  xs == ys = C.toOrdList xs == C.toOrdList ys++instance (Ord a, Show a) => Show (Heap a) where+  showsPrec = showsPrecUsingToList++instance (Ord a, Read a) => Read (Heap a) where+  readsPrec = readsPrecUsingFromList++instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where+  arbitrary = sized (\n -> arbTree n)+    where arbTree 0 = return E+          arbTree n =+            frequency [(1, return E),+                       (2, liftM2 sift1 arbitrary (arbTree (n - 1))),+                       (3, liftM3 sift arbitrary (arbTree (n `div` 4))+                                                 (arbTree (n `div` 2)))]++          sift x E a = sift1 x a+          sift x a E = let H1 x' a' = sift1 x a in H2 x' a' E+          sift x a b+              | x <= ma && x <= mb = H2 x a b+              | ma < x && ma <= mb = H2 ma (siftInto x a) b+              | otherwise          = H2 mb a (siftInto x b)+            where ma = minElem a+                  mb = minElem b++          sift1 x E = H1 x E+          sift1 x a +              | x <= ma   = H1 x a+              | otherwise = H1 ma (siftInto x a)+            where ma = minElem a++          siftInto x (H1 _ a) = sift1 x a+          siftInto x (H2 _ a b) = sift x a b+          siftInto x E = error "LazyPairingHeap.arbitrary: bug!"++  coarbitrary E = variant 0+  coarbitrary (H1 x a) = variant 1 . coarbitrary x . coarbitrary a+  coarbitrary (H2 x a b) =+      variant 2 . coarbitrary x . coarbitrary a . coarbitrary b++instance (Ord a) => Monoid (Heap a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a) => Ord (Heap a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/LeftistHeap.hs view
@@ -0,0 +1,489 @@+-- |+--   Module      :  Data.Edison.Coll.LeftistHeap+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Leftist Heaps+--+--   /References:/+--+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1.++module Data.Edison.Coll.LeftistHeap (+    -- * Type of leftist heaps+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',+    fold1, fold1', filter, partition, strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,+    unsafeMapMonotonic,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..), +                                   unionList, toOrdList )+import qualified Data.Edison.Seq as S+import Data.Edison.Coll.Defaults+import Data.Monoid+import Control.Monad+import Test.QuickCheck++moduleName = "Data.Edison.Coll.LeftistHeap"++data Heap a = E | L !Int !a !(Heap a) !(Heap a)++-- invariants:+--   * Heap ordered+--   * Leftist; the rank of any left node is >= the+--     rank of its right sibling.  The rank of a node+--     is the length of its right spine.++structuralInvariant :: Ord a => Heap a -> Bool+structuralInvariant E = True+structuralInvariant t@(L i x l r) =+    i == rank t && isMin x t && checkLeftist t++ where rank E = 0+       rank (L _ _ _ r) = (rank r) + 1++       isMin x E = True+       isMin x (L _ y l r) = x <= y && (isMin y l) && (isMin y r)++       checkLeftist E = True+       checkLeftist t@(L i _ l r) =+          rank l >= rank r && checkLeftist l && checkLeftist r+++node x a E = L 1 x a E+node x E b = L 1 x b E+node x a@(L m _ _ _) b@(L n _ _ _)+  | m <= n     = L (m + 1) x b a+  | otherwise  = L (n + 1) x a b++{-+Note: when we want to recurse down both sides, and we have a choice,+recursing down the smaller side first will minimize stack usage.++For delete,deleteAll,filter,partition: could compute fringe and reduce+rather that rebuilding with union at every deleted node+-}++empty :: Ord a => Heap a+empty = E++singleton :: Ord a => a -> Heap a+singleton x = L 1 x E E++insert :: Ord a => a -> Heap a -> Heap a+insert x E = L 1 x E E+insert x h@(L m y a b)+  | x <= y    = L 1 x h E+  | otherwise = node y a (insert x b)++union :: Ord a => Heap a -> Heap a -> Heap a+union E h = h+union h@(L _ x a b) h' = union' h x a b h'+  where union' h x a b E = h+        union' hx x a b hy@(L _ y c d)+          | x <= y    = node x a (union' hy y c d b)+          | otherwise = node y c (union' hx x a b d)++{-+union E h = h+union h E = h+union h1@(L _ x a b) h2@(L _ y c d)+  | x <= y    = node x a (union b h2)+  | otherwise = node y c (union h1 d)+    -- ??? optimize to catch fact that h1 or h2 is known to be L case?+-}++delete :: Ord a => a -> Heap a -> Heap a+delete x h = case del h of+               Just h' -> h'+               Nothing -> h+  where del (L _ y a b) =+          case compare x y of+            LT -> Nothing+            EQ -> Just (union a b)+            GT -> case del b of+                    Just b' -> Just (node y a b')+                    Nothing -> case del a  of+                                 Just a' -> Just (node y a' b)+                                 Nothing -> Nothing+        del E = Nothing++deleteAll :: Ord a => a -> Heap a -> Heap a+deleteAll x h@(L _ y a b) =+  case compare x y of+    LT -> h+    EQ -> union (deleteAll x a) (deleteAll x b)+    GT -> node y (deleteAll x a) (deleteAll x b)+deleteAll x E = E++null :: Ord a => Heap a -> Bool+null E = True+null _ = False++size :: Ord a => Heap a -> Int+size h = sz h 0+  where sz E i = i+        sz (L _ _ a b) i = sz a (sz b (i + 1))++member :: Ord a => a -> Heap a -> Bool+member x E = False+member x (L _ y a b) =+  case compare x y of+    LT -> False+    EQ -> True+    GT -> member x b || member x a++count :: Ord a => a -> Heap a -> Int+count x E = 0+count x (L _ y a b) =+  case compare x y of+    LT -> 0+    EQ -> 1 + count x b + count x a+    GT -> count x b + count x a++toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a+toSeq h = tol h S.empty+  where tol E rest = rest+        tol (L _ x a b) rest = S.lcons x (tol b (tol a rest))++lookupM :: (Ord a, Monad m) => a -> Heap a -> m a+lookupM x E = fail "LeftistHeap.lookupM: XXX"+lookupM x (L _ y a b) =+  case compare x y of+    LT -> fail "LeftistHeap.lookupM: XXX"+    EQ -> return y+    GT -> case lookupM x b `mplus` lookupM x a of+                Nothing -> fail "LeftistHeap.lookupM: XXX"+                Just x  -> return x++lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a+lookupAll x h = look h S.empty+  where look E ys = ys+        look (L _ y a b) ys =+          case compare x y of+            LT -> ys+            EQ -> S.lcons y (look b (look a ys))+            GT -> look b (look a ys)++fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold f e E = e+fold f e (L _ x a b) = f x (fold f (fold f e a) b)++fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold' f e E = e+fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b)++fold1 :: Ord a => (a -> a -> a) -> Heap a -> a+fold1 f E = error "LeftistHeap.fold1: empty collection"+fold1 f (L _ x a b) = fold f (fold f x a) b++fold1' :: Ord a => (a -> a -> a) -> Heap a -> a+fold1' f E = error "LeftistHeap.fold1': empty collection"+fold1' f (L _ x a b) = fold' f (fold' f x a) b+++filter :: Ord a => (a -> Bool) -> Heap a -> Heap a+filter p E = E+filter p (L _ x a b)+    | p x = node x (filter p a) (filter p b)+    | otherwise = union (filter p a) (filter p b)++partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)+partition p E = (E, E)+partition p (L _ x a b)+    | p x = (node x a' b', union a'' b'')+    | otherwise = (union a' b', node x a'' b'')+  where (a', a'') = partition p a+        (b', b'') = partition p b+++deleteMin :: Ord a => Heap a -> Heap a+deleteMin E = E+deleteMin (L _ x a b) = union a b++deleteMax :: Ord a => Heap a -> Heap a+deleteMax h = case maxView h of+                Nothing     -> E+                Just (x,h') -> h'++unsafeInsertMin :: Ord a => a -> Heap a -> Heap a+unsafeInsertMin x h = L 1 x h E++unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a+unsafeAppend E h = h+unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h)++filterLT :: Ord a => a -> Heap a -> Heap a+filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b)+filterLT y _ = E++filterLE :: Ord a => a -> Heap a -> Heap a+filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b)+filterLE y _ = E++filterGT :: Ord a => a -> Heap a -> Heap a+filterGT y h = C.unionList (collect h [])+  where collect E hs = hs+        collect h@(L _ x a b) hs+          | x > y = h : hs+          | otherwise = collect a (collect b hs)++filterGE :: Ord a => a -> Heap a -> Heap a+filterGE y h = C.unionList (collect h [])+  where collect E hs = hs+        collect h@(L _ x a b) hs+          | x >= y = h : hs+          | otherwise = collect b (collect a hs)++partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GE y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(L _ x a b) hs+          | x >= y = (E, h:hs)+          | otherwise = let (a', hs') = collect a hs+                            (b', hs'') = collect b hs'+                        in (node x a' b', hs'')++partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLE_GT y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(L _ x a b) hs+          | x > y = (E, h:hs)+          | otherwise = let (a', hs') = collect a hs+                            (b', hs'') = collect b hs'+                        in (node x a' b', hs'')++partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GT y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(L _ x a b) hs = +          case compare x y of+            GT -> (E, h:hs)+            EQ -> let (a', hs') = collect a hs+                      (b', hs'') = collect b hs'+                  in (union a' b', hs'')+            LT -> let (a', hs') = collect a hs+                      (b', hs'') = collect b hs'+                  in (node x a' b', hs'')++minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+minView E = fail "LeftistHeap.minView: empty collection"+minView (L _ x a b) = return (x, union a b)++minElem :: Ord a => Heap a -> a+minElem E = error "LeftistHeap.minElem: empty collection"+minElem (L _ x a b) = x++maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+maxView E = fail "LeftistHeap.maxView: empty collection"+maxView (L _ x E _) = return (x, E)+maxView (L _ x a E) = return (y, L 1 x a' E)+  where Just (y,a') = maxView a+maxView (L _ x a b)+    | y >= z    = return (y, node x a' b)+    | otherwise = return (z, node x a b')+  where Just (y, a') = maxView a+        Just (z, b') = maxView b++-- warning: maxView and maxElem may disagree if root is equal to max!++maxElem :: Ord a => Heap a -> a+maxElem E = error "LeftistHeap.maxElem: empty collection"+maxElem (L _ x E _) = x+maxElem (L _ x a b) = findMax b (findLeaf a)+  where findMax E m = m+        findMax (L _ x E _) m+          | m >= x = m+          | otherwise = x+        findMax (L _ x a b) m = findMax a (findMax b m)++        findLeaf E = error "LeftistHeap.maxElem: bug"+        findLeaf (L _ x E _) = x+        findLeaf (L _ x a b) = findMax b (findLeaf a)++foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr f e E = e+foldr f e (L _ x a b) = f x (foldr f e (union a b))++foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr' f e E = e+foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b))++foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl f e E = e+foldl f e (L _ x a b) = foldl f (f e x) (union a b)++foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl' f e E = e+foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b)++foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1 f E = error "LeftistHeap.foldr1: empty collection"+foldr1 f (L _ x E _) = x+foldr1 f (L _ x a b) = f x (foldr1 f (union a b))++foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1' f E = error "LeftistHeap.foldr1': empty collection"+foldr1' f (L _ x E _) = x+foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b))++foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1 f E = error "LeftistHeap.foldl1: empty collection"+foldl1 f (L _ x a b) = foldl f x (union a b)++foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1' f E = error "LeftistHeap.foldl1: empty collection"+foldl1' f (L _ x a b) = foldl' f x (union a b)++{- ???? -}+unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a+unsafeMapMonotonic f E = E+unsafeMapMonotonic f (L i x a b) =+  L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)+++-- all fields are already fully strict!+strict :: Heap a -> Heap a+strict h = h++strictWith :: (a -> b) -> Heap a -> Heap a+strictWith f h@E = h+strictWith f h@(L i x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h++-- the remaining functions all use default definitions++fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+fromSeq = fromSeqUsingUnionSeq++insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+insertSeq = insertSeqUsingUnion++unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a+unionSeq = unionSeqUsingReduce++deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+deleteSeq = deleteSeqUsingDelete++lookup :: Ord a => a -> Heap a -> a+lookup = lookupUsingLookupM++lookupWithDefault :: Ord a => a -> a -> Heap a -> a+lookupWithDefault = lookupWithDefaultUsingLookupM++unsafeInsertMax :: Ord a => a -> Heap a -> Heap a+unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend++unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin++toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a+toOrdSeq = toOrdSeqUsingFoldr+++-- instance declarations++instance Ord a => C.CollX (Heap a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Heap a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Heap a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance Ord a => C.OrdColl (Heap a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr';+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; +   foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}++instance Ord a => Eq (Heap a) where+  xs == ys = C.toOrdList xs == C.toOrdList ys++instance (Ord a, Show a) => Show (Heap a) where+  showsPrec = showsPrecUsingToList++instance (Ord a, Read a) => Read (Heap a) where+  readsPrec = readsPrecUsingFromList+++instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where+  arbitrary = sized (\n -> arbTree n)+    where arbTree 0 = return E+          arbTree n =+            frequency [(1, return E),+                       (4, liftM3 snode arbitrary (arbTree (n `div` 2))+                                                  (arbTree (n `div` 4)))]++          snode x a b = sift (node x a b)++          sift E = E+          sift t@(L _ x a E)+            | a == E || x <= minElem a = t+          sift (L r x (L r' y a b) E) =+                L r y (sift (L r' x a b)) E+          sift t@(L r x a b)+            | x <= minElem a && x <= minElem b = t+          sift (L r x (L r' y a b) c)+            | y <= minElem c =+                L r y (sift (L r' x a b)) c+          sift (L r x a (L r' y b c)) =+                L r y a (sift (L r' x b c))+          sift _ = error "LeftistHeap.arbitrary: bug!"++  coarbitrary E = variant 0+  coarbitrary (L _ x a b) = +      variant 1 . coarbitrary x . coarbitrary a . coarbitrary b++instance (Ord a) => Monoid (Heap a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a) => Ord (Heap a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/MinHeap.hs view
@@ -0,0 +1,406 @@+-- |+--   Module      :  Data.Edison.Coll.MinHeap+--   Copyright   :  Copyright (c) 1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   A generic adaptor for bags to keep the minimum element separately.++module Data.Edison.Coll.MinHeap (+    -- * Min heap adaptor type+    Min, -- instance of Coll/CollX, OrdColl/OrdCollX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',+    fold1, fold1', filter, partition, strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,+    unsafeMapMonotonic,++    -- * Other supported operations+    toColl,fromColl,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq as S+import Data.Edison.Coll.Defaults+import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)+import Data.Monoid+import Control.Monad+import Test.QuickCheck++data Min h a = E | M a h  deriving (Eq)++moduleName = "Data.Edison.Coll.MinHeap"++instanceName E = "MinHeap(empty)"+instanceName (M x h) = "MinHeap(" ++ C.instanceName h ++ ")"++structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool+structuralInvariant E = True+structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h++empty     :: Min h a+singleton :: (C.CollX h a,Ord a) => a -> Min h a+fromSeq   :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a+insert    :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a+insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a+union     :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a+unionSeq  :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a+delete    :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a+deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a+deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a+null      :: Min h a -> Bool+size      :: C.CollX h a => Min h a -> Int+member    :: (C.CollX h a,Ord a) => a -> Min h a -> Bool+count     :: (C.CollX h a,Ord a) => a -> Min h a -> Int+strict    :: (C.CollX h a,Ord a) => Min h a -> Min h a++toSeq     :: (C.Coll h a,S.Sequence s) => Min h a -> s a+lookup    :: (C.Coll h a,Ord a) => a -> Min h a -> a+lookupM   :: (C.Coll h a,Ord a,Monad m) => a -> Min h a -> m a+lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a+lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a+fold      :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b+fold1     :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a+fold'     :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b+fold1'    :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a+filter    :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a+partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a)+strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a++deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a+deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a+unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a+unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a+unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a+unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a+filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a+filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a+filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a+filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a+partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)+partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)+partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)++minView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a)+minElem :: (C.OrdColl h a,Ord a) => Min h a -> a+maxView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a)+maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a+foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b+foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b+foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a+foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a+foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b+foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b+foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a+foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a+toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a+unsafeMapMonotonic :: (C.OrdColl h a,Ord a) => +      (a -> a) -> Min h a -> Min h a++fromColl :: C.OrdColl h a => h -> Min h a+fromColl = fromPrim++toColl :: C.OrdColl h a => Min h a -> h+toColl = toPrim++fromPrim xs = case C.minView xs of+                Nothing -> E+                Just (x, xs') -> M x xs'++toPrim E = C.empty+toPrim (M x xs) = C.unsafeInsertMin x xs++empty = E+singleton x = M x C.empty++fromSeq = fromPrim . C.fromSeq++insert x E = M x C.empty+insert x (M y xs)+  | x <= y    = M x (C.unsafeInsertMin y xs)+  | otherwise = M y (C.insert x xs)++insertSeq xs E = fromSeq xs+insertSeq xs (M y ys) = +    case C.minView xs_ys of+      Nothing -> M y C.empty+      Just (x, rest)+          | x < y     -> M x (C.insert y rest)+          | otherwise -> M y xs_ys+  where xs_ys = C.insertSeq xs ys++union E ys = ys+union xs E = xs+union (M x xs) (M y ys)+  | x <= y    = M x (C.union xs (C.unsafeInsertMin y ys))+  | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys)++unionSeq = unionSeqUsingReduce++delete x E = E+delete x m@(M y ys)+  | x > y     = M y (C.delete x ys)+  | x == y    = fromPrim ys+  | otherwise = m++deleteAll x E = E+deleteAll x m@(M y ys)+  | x > y     = M y (C.deleteAll x ys)+  | x == y    = fromPrim (C.deleteAll x ys)+  | otherwise = m++deleteSeq = deleteSeqUsingDelete++null E = True+null (M x xs) = False++size E = 0+size (M x xs) = 1 + C.size xs+++member x E = False+member x (M y ys)+  | x > y     = C.member x ys+  | otherwise = (x == y)++count x E = 0+count x (M y ys)+  | x > y     = C.count x ys+  | x == y    = 1 + C.count x ys+  | otherwise = 0++toSeq E = S.empty+toSeq (M x xs) = S.lcons x (C.toSeq xs)++lookup x (M y ys)+  | x > y  = C.lookup x ys+  | x == y = y+lookup _ _ = error "MinHeap.lookup: empty heap"++lookupM x (M y ys)+  | x > y  = C.lookupM x ys+  | x == y = return y+lookupM _ _ = fail "lookupM.lookup: XXX"++lookupAll x (M y ys)+  | x > y  = C.lookupAll x ys+  | x == y = S.lcons y (C.lookupAll x ys)+lookupAll _ _ = S.empty++lookupWithDefault d x (M y ys)+  | x > y  = C.lookupWithDefault d x ys+  | x == y = y+lookupWithDefault d _ _ = d++fold f e E = e+fold f e (M x xs) = f x (C.fold f e xs)++fold' f e E = e+fold' f e (M x xs) = f x $! (C.fold' f e xs)++fold1 f E = error "MinHeap.fold1: empty heap"+fold1 f (M x xs) = C.fold f x xs++fold1' f E = error "MinHeap.fold1': empty heap"+fold1' f (M x xs) = C.fold' f x xs++filter p E = E+filter p (M x xs)+  | p x       = M x (C.filter p xs)+  | otherwise = fromPrim (C.filter p xs)++partition p E = (E, E)+partition p (M x xs)+    | p x       = (M x ys, fromPrim zs)+    | otherwise = (fromPrim ys, M x zs)+  where (ys,zs) = C.partition p xs++deleteMin E = E+deleteMin (M x xs) = fromPrim xs++deleteMax E = E+deleteMax (M x xs)+  | C.null xs   = E+  | otherwise = M x (C.deleteMax xs)++unsafeInsertMin x xs = M x (toPrim xs)++unsafeInsertMax x E = M x C.empty+unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys)++unsafeFromOrdSeq xs =+  case S.lview xs of+    Nothing      -> E+    Just (x,xs') -> M x (C.unsafeFromOrdSeq xs')++unsafeAppend E ys = ys+unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys))++filterLT x (M y ys) | y < x  = M y (C.filterLT x ys)+filterLT _ _ = E++filterLE x (M y ys) | y <= x = M y (C.filterLE x ys)+filterLE _ _ = E++filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys)+filterGT x h = h++filterGE x (M y ys) | y < x  = fromPrim (C.filterGE x ys)+filterGE x h = h++partitionLT_GE x (M y ys)+  | y < x = (M y lows, fromPrim highs)+  where (lows,highs) = C.partitionLT_GE x ys+partitionLT_GE x h = (E, h)++partitionLE_GT x (M y ys) +  | y <= x = (M y lows, fromPrim highs)+  where (lows,highs) = C.partitionLE_GT x ys+partitionLE_GT x h = (E, h)++partitionLT_GT x (M y ys)+  | y < x  = let (lows,highs) = C.partitionLT_GT x ys+             in (M y lows, fromPrim highs)+  | y == x = (E, fromPrim (C.filterGT x ys))+partitionLT_GT x h = (E, h)+++minView E = fail "MinHeap.minView: empty heap"+minView (M x xs) = return (x, fromPrim xs)++minElem E = error "MinHeap.minElem: empty heap"+minElem (M x xs) = x++maxView E = fail "MinHeap.maxView: empty heap"+maxView (M x xs) = case C.maxView xs of+                     Nothing     -> return (x, E)+                     Just (y,ys) -> return (y, M x ys)++maxElem E = error "MinHeap.minElem: empty heap"+maxElem (M x xs)+  | C.null xs   = x+  | otherwise = C.maxElem xs++foldr f e E = e+foldr f e (M x xs) = f x (C.foldr f e xs)++foldr' f e E = e+foldr' f e (M x xs) = f x $! (C.foldr' f e xs)++foldl f e E = e+foldl f e (M x xs) = C.foldl f (f e x) xs++foldl' f e E = e+foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs++foldr1 f E = error "MinHeap.foldr1: empty heap"+foldr1 f (M x xs)+  | C.null xs   = x+  | otherwise = f x (C.foldr1 f xs)++foldr1' f E = error "MinHeap.foldr1': empty heap"+foldr1' f (M x xs)+  | C.null xs = x+  | otherwise = f x $! (C.foldr1' f xs)++foldl1 f E = error "MinHeap.foldl1: empty heap"+foldl1 f (M x xs) = C.foldl f x xs++foldl1' f E = error "MinHeap.foldl1': empty heap"+foldl1' f (M x xs) = C.foldl' f x xs++toOrdSeq E = S.empty+toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs)++unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr++strict h@E = h+strict h@(M x xs) = C.strict xs `seq` h++strictWith f h@E = h+strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h+++-- instance declarations++instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; +   foldl = foldl; foldl' = foldl'; foldr1 = foldr1;  foldr1' = foldr1';+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic}++-- instance Eq is derived++instance (C.OrdColl h a, Show h) => Show (Min h a) where+   showsPrec i xs rest+     | i == 0    = concat [    moduleName,".fromColl ",showsPrec 10 (toColl xs) rest]+     | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)]++instance (C.OrdColl h a, Read h) => Read (Min h a) where+   readsPrec i xs = maybeParens p xs+       where p xs = tokenMatch (moduleName++".fromColl") xs+                      >>= readsPrec 10+                      >>= \(coll,rest) -> return (fromColl coll,rest)++instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where+  arbitrary = do xs <- arbitrary+                 x  <- arbitrary+                 i  <- arbitrary :: Gen Int+                 return (if C.null xs || x <= C.minElem xs then M x xs+                         else if odd i then M (C.minElem xs) xs+                                       else fromPrim xs)++  coarbitrary E = variant 0+  coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs++instance (C.OrdColl h a) => Monoid (Min h a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Eq h, C.OrdColl h a) => Ord (Min h a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/SkewHeap.hs view
@@ -0,0 +1,457 @@+-- |+--   Module      :  Data.Edison.Coll.SkewHeap+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Skew heaps.+--+--   /References:/+--+-- * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\".+--   /SIAM Journal on Computing/, 15(1):52-69, February 1986.++module Data.Edison.Coll.SkewHeap (+    -- * Type of skew heaps+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',+    fold1, fold1', filter, partition, strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,+    unsafeMapMonotonic,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq as S+import Data.Edison.Coll.Defaults+import Data.Monoid+import Control.Monad+import Test.QuickCheck++moduleName = "Data.Edison.Coll.SkewHeap"++data Heap a = E | T a (Heap a) (Heap a)++-- invariants:+--  * Heap order+structuralInvariant :: Ord a => Heap a -> Bool+structuralInvariant E = True+structuralInvariant t@(T x l r) = isMin x t+  where isMin x E = True+        isMin x (T y l r) = x <= y && isMin y l && isMin y r+++{-+For delete,deleteAll,filter,partition: could compute fringe and reduce+rather that rebuilding with union at every deleted node+-}++empty :: Ord a => Heap a+empty = E++singleton :: Ord a => a -> Heap a+singleton x = T x E E++insert :: Ord a => a -> Heap a -> Heap a+insert x E = T x E E+insert x h@(T y a b)+  | x <= y    = T x h E+  | otherwise = T y (insert x b) a++union :: Ord a => Heap a -> Heap a -> Heap a+union E h = h+union h@(T x a b) h' = union' h x a b h'+  where union' h x a b E = h+        union' hx x a b hy@(T y c d)+          | x <= y    = T x (union' hy y c d b) a+          | otherwise = T y (union' hx x a b d) c++delete :: Ord a => a -> Heap a -> Heap a+delete x h = case del h of+               Just h' -> h'+               Nothing -> h+  where del (T y a b) =+          case compare x y of+            LT -> Nothing+            EQ -> Just (union a b)+            GT -> case del b of+                    Just b' -> Just (T y a b')+                    Nothing -> case del a  of+                                 Just a' -> Just (T y a' b)+                                 Nothing -> Nothing+        del E = Nothing++deleteAll :: Ord a => a -> Heap a -> Heap a+deleteAll x h@(T y a b) =+  case compare x y of+    LT -> h+    EQ -> union (deleteAll x a) (deleteAll x b)+    GT -> T y (deleteAll x a) (deleteAll x b)+deleteAll x E = E++null :: Ord a => Heap a -> Bool+null E = True+null _ = False++size :: Ord a => Heap a -> Int+size h = sz h 0+  where sz E i = i+        sz (T _ a b) i = sz a (sz b (i + 1))++member :: Ord a => a -> Heap a -> Bool+member x E = False+member x (T y a b) =+  case compare x y of+    LT -> False+    EQ -> True+    GT -> member x b || member x a++count :: Ord a => a -> Heap a -> Int+count x E = 0+count x (T y a b) =+  case compare x y of+    LT -> 0+    EQ -> 1 + count x b + count x a+    GT -> count x b + count x a++toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a+toSeq h = tol h S.empty+  where tol E rest = rest+        tol (T x a b) rest = S.lcons x (tol b (tol a rest))++lookupM :: (Ord a, Monad m) => a -> Heap a -> m a+lookupM x E = fail "SkewHeap.lookupM: XXX"+lookupM x (T y a b) =+  case compare x y of+    LT -> fail "SkewHeap.lookupM: XXX"+    EQ -> return y+    GT -> case lookupM x b `mplus` lookupM x a of+                Nothing -> fail "SkewHeap.lookupM: XXX"+                Just x  -> return x++lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a+lookupAll x h = look h S.empty+  where look E ys = ys+        look (T y a b) ys =+          case compare x y of+            LT -> ys+            EQ -> S.lcons y (look b (look a ys))+            GT -> look b (look a ys)++fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold f e E = e+fold f e (T x a b) = f x (fold f (fold f e a) b)++fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold' f e E = e+fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b)++fold1 :: Ord a => (a -> a -> a) -> Heap a -> a+fold1 f E = error "SkewHeap.fold1: empty collection"+fold1 f (T x a b) = fold f (fold f x a) b++fold1' :: Ord a => (a -> a -> a) -> Heap a -> a+fold1' f E = error "SkewHeap.fold1': empty collection"+fold1' f (T x a b) = fold' f (fold' f x a) b++filter :: Ord a => (a -> Bool) -> Heap a -> Heap a+filter p E = E+filter p (T x a b)+    | p x = T x (filter p a) (filter p b)+    | otherwise = union (filter p a) (filter p b)++partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)+partition p E = (E, E)+partition p (T x a b)+    | p x = (T x a' b', union a'' b'')+    | otherwise = (union a' b', T x a'' b'')+  where (a', a'') = partition p a+        (b', b'') = partition p b+++deleteMin :: Ord a => Heap a -> Heap a+deleteMin E = E+deleteMin (T x a b) = union a b++deleteMax :: Ord a => Heap a -> Heap a+deleteMax h = case maxView h of+                Nothing     -> E+                Just (x,h') -> h'++unsafeInsertMin :: Ord a => a -> Heap a -> Heap a+unsafeInsertMin x h = T x h E++unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a+unsafeAppend E h = h+unsafeAppend (T x a b) h = T x (unsafeAppend b h) a++filterLT :: Ord a => a -> Heap a -> Heap a+filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b)+filterLT y _ = E++filterLE :: Ord a => a -> Heap a -> Heap a+filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b)+filterLE y _ = E++filterGT :: Ord a => a -> Heap a -> Heap a+filterGT y h = C.unionList (collect h [])+  where collect E hs = hs+        collect h@(T x a b) hs+          | x > y = h : hs+          | otherwise = collect a (collect b hs)++filterGE :: Ord a => a -> Heap a -> Heap a+filterGE y h = C.unionList (collect h [])+  where collect E hs = hs+        collect h@(T x a b) hs+          | x >= y = h : hs+          | otherwise = collect b (collect a hs)++partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GE y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(T x a b) hs+          | x >= y = (E, h:hs)+          | otherwise = let (a', hs') = collect a hs+                            (b', hs'') = collect b hs'+                        in (T x a' b', hs'')++partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLE_GT y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(T x a b) hs+          | x > y = (E, h:hs)+          | otherwise = let (a', hs') = collect a hs+                            (b', hs'') = collect b hs'+                        in (T x a' b', hs'')++partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GT y h = (h', C.unionList hs)+  where (h', hs) = collect h []++        collect E hs = (E, hs)+        collect h@(T x a b) hs = +          case compare x y of+            GT -> (E, h:hs)+            EQ -> let (a', hs') = collect a hs+                      (b', hs'') = collect b hs'+                  in (union a' b', hs'')+            LT -> let (a', hs') = collect a hs+                      (b', hs'') = collect b hs'+                  in (T x a' b', hs'')++minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+minView E = fail "SkewHeap.minView: empty heap"+minView (T x a b) = return (x, union a b)++minElem :: Ord a => Heap a -> a+minElem E = error "SkewHeap.minElem: empty collection"+minElem (T x a b) = x++maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)+maxView E = fail "SkewHeap.maxView: empty heap"+maxView (T x E E) = return (x, E)+maxView (T x a E) = return (y, T x a' E)+  where Just (y, a') = maxView a+maxView (T x E a) = return (y, T x a' E)+  where Just (y, a') = maxView a+maxView (T x a b)+    | y >= z    = return (y, T x a' b)+    | otherwise = return (z, T x a b')+  where Just (y, a') = maxView a+        Just (z, b') = maxView b++-- warning: maxView and maxElem may disagree if root is equal to max!++maxElem :: Ord a => Heap a -> a+maxElem E = error "SkewHeap.maxElem: empty collection"+maxElem (T x E E) = x+maxElem (T x a E) = maxElem a+maxElem (T x E a) = maxElem a+maxElem (T x a b) = findMax b (findLeaf a)+  where findMax E m = m+        findMax (T x E E) m+          | m >= x = m+          | otherwise = x+        findMax (T x a E) m = findMax a m+        findMax (T x E a) m = findMax a m+        findMax (T x a b) m = findMax a (findMax b m)++        findLeaf E = error "SkewHeap.maxElem: bug"+        findLeaf (T x E E) = x+        findLeaf (T x a E) = findLeaf a+        findLeaf (T x E a) = findLeaf a+        findLeaf (T x a b) = findMax b (findLeaf a)++foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr f e E = e+foldr f e (T x a b) = f x (foldr f e (union a b))++foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldr' f e E = e+foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b))++foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl f e E = e+foldl f e (T x a b) = foldl f (f e x) (union a b)++foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldl' f e E = e+foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b)++foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1 f E = error "SkewHeap.foldr1: empty collection"+foldr1 f (T x E E) = x+foldr1 f (T x a b) = f x (foldr1 f (union a b))++foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldr1' f E = error "SkewHeap.foldr1': empty collection"+foldr1' f (T x E E) = x+foldr1' f (T x a b) = f x $! (foldr1' f (union a b))++foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1 f E = error "SkewHeap.foldl1: empty collection"+foldl1 f (T x a b) = foldl f x (union a b)++foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1' f E = error "SkewHeap.foldl1': empty collection"+foldl1' f (T x a b) = foldl' f x (union a b)++{- ???? -}+unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a+unsafeMapMonotonic f E = E+unsafeMapMonotonic f (T x a b) =+  T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)+++strict :: Heap a -> Heap a+strict h@E = h+strict h@(T x l r) = strict l `seq` strict r `seq` h++strictWith :: (a -> b) -> Heap a -> Heap a+strictWith f h@E = h+strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h++-- the remaining functions all use default definitions++fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+fromSeq = fromSeqUsingUnionSeq++insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+insertSeq = insertSeqUsingUnion++unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a+unionSeq = unionSeqUsingReduce++deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a+deleteSeq = deleteSeqUsingDelete++lookup :: Ord a => a -> Heap a -> a+lookup = lookupUsingLookupM++lookupWithDefault :: Ord a => a -> a -> Heap a -> a+lookupWithDefault = lookupWithDefaultUsingLookupM++unsafeInsertMax :: Ord a => a -> Heap a -> Heap a+unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend++unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin++toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a+toOrdSeq = toOrdSeqUsingFoldr++-- instance declarations++instance Ord a => C.CollX (Heap a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Heap a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Heap a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance Ord a => C.OrdColl (Heap a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr';+   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';+   foldl1  = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic}++instance Ord a => Eq (Heap a) where+  xs == ys = C.toOrdList xs == C.toOrdList ys++instance (Ord a, Show a) => Show (Heap a) where+  showsPrec = showsPrecUsingToList++instance (Ord a, Read a) => Read (Heap a) where+  readsPrec = readsPrecUsingFromList+++instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where+  arbitrary = sized (\n -> arbTree n)+    where arbTree 0 = return E+          arbTree n =+            frequency [(1, return E),+                       (4, liftM3 sift arbitrary (arbTree (n `div` 2))+                                                 (arbTree (n `div` 4)))]++          sift x s@(T y a b) E+            | y < x = T y (sift x a b) E+          sift x E s@(T y a b)+            | y < x = T y E (sift x a b)+          sift x s@(T y a b) t@(T z c d)+            | y < x && y <= z = T y (sift x a b) t+            | z < x           = T z s (sift x c d)+          sift x a b = T x a b++  coarbitrary E = variant 0+  coarbitrary (T x a b) = +      variant 1 . coarbitrary x . coarbitrary a . coarbitrary b++instance (Ord a) => Monoid (Heap a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a) => Ord (Heap a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/SplayHeap.hs view
@@ -0,0 +1,493 @@+-- |+--   Module      :  Data.Edison.Coll.SplayHeap+--   Copyright   :  Copyright (c) 1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Splay heaps.+--+--   If 'minElem' is called frequently, then SplayHeap should+--   be used in conjunction with "Data.Edison.Coll.MinHeap".+--+--   /References:/+--+-- * Chris Okasaki. /Purely Functional Data Structures/. 1998.+--   Section 5.4.++module Data.Edison.Coll.SplayHeap (+    -- * Type of splay heaps+    Heap, -- instance of Coll/CollX, OrdColl/OrdCollX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',+    fold1, fold1', filter, partition, strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,+    unsafeMapMonotonic,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq as S+import Data.Edison.Coll.Defaults+import Data.Monoid+import Control.Monad+import Test.QuickCheck++moduleName = "Data.Edison.Coll.SplayHeap"++data Heap a = E | T (Heap a) a (Heap a)++-- invariants:+--    * Binary Search Tree order (allowing duplicates)++structuralInvariant :: Ord a => Heap a -> Bool+structuralInvariant t = bounded Nothing Nothing t+   where bounded _ _ E = True+         bounded lo hi (T l x r)  = cmp_l lo x +                                 && cmp_r x hi+                                 && bounded lo (Just x) l+                                 && bounded (Just x) hi r++         cmp_l Nothing  _ = True+         cmp_l (Just x) y = x <= y++         cmp_r _ Nothing  = True+         cmp_r x (Just y) = x <= y+++empty     :: Heap a+singleton :: a -> Heap a+fromSeq   :: (Ord a,S.Sequence s) => s a -> Heap a+insert    :: Ord a => a -> Heap a -> Heap a+insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a+union     :: Ord a => Heap a -> Heap a -> Heap a+unionSeq  :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a+delete    :: Ord a => a -> Heap a -> Heap a+deleteAll :: Ord a => a -> Heap a -> Heap a+deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a+null      :: Heap a -> Bool+size      :: Heap a -> Int+member    :: Ord a => a -> Heap a -> Bool+count     :: Ord a => a -> Heap a -> Int+strict    :: Heap a -> Heap a++toSeq     :: (Ord a, S.Sequence s) => Heap a -> s a+lookup    :: Ord a => a -> Heap a -> a+lookupM   :: (Ord a,Monad m) => a -> Heap a -> m a+lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a+lookupWithDefault :: Ord a => a -> a -> Heap a -> a+fold      :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold1     :: Ord a => (a -> a -> a) -> Heap a -> a+fold'     :: Ord a => (a -> b -> b) -> b -> Heap a -> b+fold1'    :: Ord a => (a -> a -> a) -> Heap a -> a+filter    :: Ord a => (a -> Bool) -> Heap a -> Heap a+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)+strictWith :: (a -> b) -> Heap a -> Heap a++deleteMin        :: Ord a => Heap a -> Heap a+deleteMax        :: Ord a => Heap a -> Heap a+unsafeInsertMin  :: Ord a => a -> Heap a -> Heap a+unsafeInsertMax  :: Ord a => a -> Heap a -> Heap a+unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a+unsafeAppend     :: Ord a => Heap a -> Heap a -> Heap a+filterLT         :: Ord a => a -> Heap a -> Heap a+filterLE         :: Ord a => a -> Heap a -> Heap a+filterGT         :: Ord a => a -> Heap a -> Heap a+filterGE         :: Ord a => a -> Heap a -> Heap a+partitionLT_GE   :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLE_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)+partitionLT_GT   :: Ord a => a -> Heap a -> (Heap a, Heap a)++minView  :: (Ord a,Monad m) => Heap a -> m (a, Heap a)+minElem  :: Ord a => Heap a -> a+maxView  :: (Ord a,Monad m) => Heap a -> m (a, Heap a)+maxElem  :: Ord a => Heap a -> a+foldr    :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldl    :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldr1   :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1   :: Ord a => (a -> a -> a) -> Heap a -> a+foldr'   :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldl'   :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldr1'  :: Ord a => (a -> a -> a) -> Heap a -> a+foldl1'  :: Ord a => (a -> a -> a) -> Heap a -> a+toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a++unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b++empty = E+singleton x = T E x E++insert x xs = T a x b+  where (a,b) = partitionLE_GT x xs++union E ys = ys+union (T a x b) ys = T (union c a) x (union d b)+  where (c,d) = partitionLE_GT x ys++delete x xs =+  let (a,b) = partitionLE_GT x xs+  in case maxView a of+       Nothing -> b+       Just (y, a')+         | x > y -> T a' y b+         | otherwise -> unsafeAppend a' b++deleteAll x xs = unsafeAppend a b+  where (a,b) = partitionLT_GT x xs++null E = True+null (T a x b) = False++size = sz 0+  where sz n E = n+        sz n (T a x b) = sz (sz (1+n) a) b+  +member x E = False+member x (T a y b) = if x < y then member x a else x==y || member x b++count = cnt 0+  where cnt n x E = n+        cnt n x (T a y b)+          | x < y = cnt n x a+          | x > y = cnt n x b+          | otherwise = cnt (cnt (1+n) x a) x b++toSeq xs = tos xs S.empty+  where tos E rest = rest+        tos (T a x b) rest = S.lcons x (tos a (tos b rest))++lookup x E = error "SplayHeap.lookup: empty heap"+lookup x (T a y b)+  | x < y     = lookup x a+  | x > y     = lookup x b+  | otherwise = y++lookupM x E = fail "SplayHeap.lookup: empty heap"+lookupM x (T a y b)+  | x < y     = lookupM x a+  | x > y     = lookupM x b+  | otherwise = return y++lookupWithDefault d x E = d+lookupWithDefault d x (T a y b)+  | x < y     = lookupWithDefault d x a+  | x > y     = lookupWithDefault d x b+  | otherwise = y++lookupAll x xs = look xs x S.empty+  where look E x rest = rest+        look (T a y b) x rest+          | x < y     = look a x rest+          | x > y     = look b x rest+          | otherwise = look a x (S.lcons y (look b x rest))++fold f e E = e+fold f e (T a x b) = f x (fold f (fold f e b) a)++fold' f e E = e+fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a)++fold1 f E = error "SplayHeap.fold1: empty heap"+fold1 f (T a x b) = fold f (fold f x b) a++fold1' f E = error "SplayHeap.fold1': empty heap"+fold1' f (T a x b) = fold' f (fold' f x b) a++filter p E = E+filter p (T a x b) +  | p x       = T (filter p a) x (filter p b)+  | otherwise = unsafeAppend (filter p a) (filter p b)++partition p E = (E, E)+partition p (T a x b)+    | p x       = (T a0 x b0, unsafeAppend a1 b1)+    | otherwise = (unsafeAppend a0 b0, T a1 x b1)+  where (a0,a1) = partition p a+        (b0,b1) = partition p b++deleteMin E = E+deleteMin (T a x b) = del a x b+  where del E x b = b+        del (T E x b) y c = T b y c+        del (T (T a x b) y c) z d = T (del a x b) y (T c z d)++deleteMax E = E+deleteMax (T a x b) = del a x b+  where del a x E = a+        del a x (T b y E) = T a x b+        del a x (T b y (T c z d)) = T (T a x b) y (del c z d)++unsafeInsertMin x xs = T E x xs+unsafeInsertMax x xs = T xs x E++unsafeAppend a b = case maxView a of+                       Nothing      -> b+                       Just (x, a') -> T a' x b++filterLT k E = E+filterLT k t@(T a x b) = +  if x >= k then filterLT k a+  else case b of+         E -> t+         T ba y bb ->+           if y >= k then T a x (filterLT k ba) +                     else T (T a x ba) y (filterLT k bb)++filterLE k E = E+filterLE k t@(T a x b) = +  if x > k then filterLE k a+  else case b of+         E -> t+         T ba y bb ->+           if y > k then T a x (filterLE k ba) +                    else T (T a x ba) y (filterLE k bb)++filterGT k E = E+filterGT k t@(T a x b) =+  if x <= k then filterGT k b+  else case a of+         E -> t+         T aa y ab ->+           if y <= k then T (filterGT k ab) x b+                     else T (filterGT k aa) y (T ab x b)++filterGE k E = E+filterGE k t@(T a x b) =+  if x < k then filterGE k b+  else case a of+         E -> t+         T aa y ab ->+           if y < k then T (filterGE k ab) x b+                    else T (filterGE k aa) y (T ab x b)++partitionLT_GE k E = (E,E)+partitionLT_GE k t@(T a x b) =+  if x >= k then+    case a of+      E -> (E,t)+      T aa y ab ->+        if y >= k then+          let (small,big) = partitionLT_GE k aa+          in (small, T big y (T ab x b))+        else+          let (small,big) = partitionLT_GE k ab+          in (T aa y small, T big x b)+  else+    case b of+      E -> (t,E)+      T ba y bb ->+        if y >= k then+          let (small,big) = partitionLT_GE k ba+          in (T a x small, T big y bb)+        else+          let (small,big) = partitionLT_GE k bb+          in (T (T a x ba) y small, big)++partitionLE_GT k E = (E,E)+partitionLE_GT k t@(T a x b) =+  if x > k then+    case a of+      E -> (E,t)+      T aa y ab ->+        if y > k then+          let (small,big) = partitionLE_GT k aa+          in (small, T big y (T ab x b))+        else+          let (small,big) = partitionLE_GT k ab+          in (T aa y small, T big x b)+  else+    case b of+      E -> (t,E)+      T ba y bb ->+        if y > k then+          let (small,big) = partitionLE_GT k ba+          in (T a x small, T big y bb)+        else+          let (small,big) = partitionLE_GT k bb+          in (T (T a x ba) y small, big)+++-- could specialize calls to filterLT/filterGT+partitionLT_GT k E = (E,E)+partitionLT_GT k t@(T a x b) =+  if x > k then+    case a of+      E -> (E,t)+      T aa y ab ->+        if y > k then+          let (small,big) = partitionLT_GT k aa+          in (small, T big y (T ab x b))+        else if y < k then+          let (small,big) = partitionLT_GT k ab+          in (T aa y small, T big x b)+        else (filterLT k aa, T (filterGT k ab) x b)+  else if x < k then+    case b of+      E -> (t,E)+      T ba y bb ->+        if y > k then+          let (small,big) = partitionLT_GT k ba+          in (T a x small, T big y bb)+        else if y < k then+          let (small,big) = partitionLT_GT k bb+          in (T (T a x ba) y small, big)+        else (T a x (filterLT k ba), filterGT k bb)+  else (filterLT k a, filterGT k b)++minView E = fail "SplayHeap.minView: empty heap"+minView (T a x b) = return (y, ys)+  where (y,ys) = minv a x b+        minv E x b = (x,b)+        minv (T E x b) y c = (x,T b y c)+        minv (T (T a x b) y c) z d = (w,T ab y (T c z d))+          where (w,ab) = minv a x b++minElem E = error "SplayHeap.minElem: empty heap"+minElem (T a x b) = minel a x+  where minel E x = x+        minel (T a x b) _ = minel a x+++maxView E = fail "SplayHeap.maxView: empty heap"+maxView (T a x b) = return (y,ys)+  where (ys,y) = maxv a x b+        maxv a x E = (a,x)+        maxv a x (T b y E) = (T a x b,y)+        maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w)+          where (cd,w) = maxv c z d++maxElem E = error "SplayHeap.minElem: empty heap"+maxElem (T a x b) = maxel x b+  where maxel x E = x+        maxel _ (T a x b) = maxel x b++foldr f e E = e+foldr f e (T a x b) = foldr f (f x (foldr f e b)) a++foldr' f e E = e+foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a++foldl f e E = e+foldl f e (T a x b) = foldl f (f (foldl f e a) x) b++foldl' f e E = e+foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b++foldr1 f E = error "SplayHeap.foldr1: empty heap"+foldr1 f (T a x b) = foldr f (myfold f x b) a+  where myfold f x E = x+        myfold f x (T a y b) = f x (foldr f (myfold f y b) a)++foldr1' f E = error "SplayHeap.foldr1': empty heap"+foldr1' f (T a x b) = foldr' f (myfold f x b) a+  where myfold f x E = x+        myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a)++foldl1 f E = error "SplayHeap.foldl1: empty heap"+foldl1 f (T a x b) = foldl f (myfold f a x) b+  where myfold f E x = x+        myfold f (T a x b) y = f (foldl f (myfold f a x) b) y++foldl1' f E = error "SplayHeap.foldl1': empty heap"+foldl1' f (T a x b) = foldl' f (myfold f a x) b+  where myfold f E x = x+        myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y++toOrdSeq xs = tos xs S.empty+  where tos E rest = rest+        tos (T a x b) rest = tos a (S.lcons x (tos b rest))++unsafeMapMonotonic f E = E+unsafeMapMonotonic f (T a x b) =+  T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)++strict h@E = h+strict h@(T l x r) = strict l `seq` strict r `seq` h++strictWith f h@E = h+strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h++-- the remaining functions all use defaults++fromSeq = fromSeqUsingFoldr+insertSeq = insertSeqUsingFoldr+unionSeq = unionSeqUsingReduce+deleteSeq = deleteSeqUsingDelete+unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin++-- instance declarations++instance Ord a => C.CollX (Heap a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Heap a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Heap a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   strictWith = strictWith;+   filter = filter; partition = partition}++instance Ord a => C.OrdColl (Heap a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; +   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic}+++instance Ord a => Eq (Heap a) where+  xs == ys = C.toOrdList xs == C.toOrdList ys++instance (Ord a, Show a) => Show (Heap a) where+  showsPrec = showsPrecUsingToList++instance (Ord a, Read a) => Read (Heap a) where+  readsPrec = readsPrecUsingFromList++instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where+  arbitrary = do xs <- arbitrary+                 return (C.fromList xs)++  coarbitrary E = variant 0+  coarbitrary (T a x b) = +    variant 1 . coarbitrary a . coarbitrary x . coarbitrary b++instance (Ord a) => Monoid (Heap a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a) => Ord (Heap a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Coll/StandardSet.hs view
@@ -0,0 +1,272 @@+-- |+--   Module      :  Data.Edison.Coll+--   Copyright   :  Copyright (c) 2006 Robert Dockins+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   The standard library "Data.Set" repackaged as an Edison collection.++module Data.Edison.Coll.StandardSet (+    -- * Set type+    Set,++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,++    -- * Coll operations+    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',+    fold1,fold1',filter,partition,strictWith,structuralInvariant,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,++    -- * SetX operations+    intersection,difference,symmetricDifference,properSubset,subset,++    -- * Set operations+    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,+    unionSeqWith,intersectionWith,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import qualified Prelude+import qualified Data.List++import Data.Edison.Prelude+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Coll.Defaults+import Test.QuickCheck++import qualified Data.Set as DS++-- signatures for exported functions+moduleName :: String+empty      :: Set a+singleton  :: a -> Set a+fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a+insert     :: Ord a => a -> Set a -> Set a+insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a+union      :: Ord a => Set a -> Set a -> Set a+unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a+delete     :: Ord a => a -> Set a -> Set a+deleteAll  :: Ord a => a -> Set a -> Set a+deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a+null       :: Set a -> Bool+size       :: Set a -> Int+member     :: Ord a => a -> Set a -> Bool+count      :: Ord a => a -> Set a -> Int+strict     :: Ord a => Set a -> Set a++toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a+lookup     :: Ord a => a -> Set a -> a+lookupM    :: (Ord a,Monad m) => a -> Set a -> m a+lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a+lookupWithDefault :: Ord a => a -> a -> Set a  -> a+fold       :: (a -> b -> b) -> b -> Set a -> b+fold1      :: (a -> a -> a) -> Set a -> a+fold'      :: (a -> b -> b) -> b -> Set a -> b+fold1'     :: (a -> a -> a) -> Set a -> a+filter     :: Ord a => (a -> Bool) -> Set a -> Set a+partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)+strictWith :: Ord a => (a -> b) -> Set a -> Set a++deleteMin        :: Ord a => Set a -> Set a+deleteMax        :: Ord a => Set a -> Set a+unsafeInsertMin  :: Ord a => a -> Set a -> Set a+unsafeInsertMax  :: Ord a => a -> Set a -> Set a+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a+unsafeAppend     :: Ord a => Set a -> Set a -> Set a+filterLT         :: Ord a => a -> Set a -> Set a+filterLE         :: Ord a => a -> Set a -> Set a+filterGT         :: Ord a => a -> Set a -> Set a+filterGE         :: Ord a => a -> Set a -> Set a+partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)+partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)+partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)++minView       :: (Ord a,Monad m) => Set a -> m (a, Set a)+minElem       :: Set a -> a+maxView       :: (Ord a,Monad m) => Set a -> m (a, Set a)+maxElem       :: Set a -> a+foldr         :: (a -> b -> b) -> b -> Set a -> b+foldl         :: (b -> a -> b) -> b -> Set a -> b+foldr1        :: (a -> a -> a) -> Set a -> a+foldl1        :: (a -> a -> a) -> Set a -> a+foldr'        :: (a -> b -> b) -> b -> Set a -> b+foldl'        :: (b -> a -> b) -> b -> Set a -> b+foldr1'       :: (a -> a -> a) -> Set a -> a+foldl1'       :: (a -> a -> a) -> Set a -> a+toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a++intersection  :: Ord a => Set a -> Set a -> Set a+difference    :: Ord a => Set a -> Set a -> Set a+symmetricDifference :: Ord a => Set a -> Set a -> Set a+properSubset  :: Ord a => Set a -> Set a -> Bool+subset        :: Ord a => Set a -> Set a -> Bool++fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a+insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a+insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a+unionl       :: Ord a => Set a -> Set a -> Set a+unionr       :: Ord a => Set a -> Set a -> Set a+unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a+unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a+intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a+unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a++moduleName = "Data.Edison.Coll.StandardSet"++type Set = DS.Set++structuralInvariant :: Ord a => Set a -> Bool+structuralInvariant = DS.valid++empty              = DS.empty+singleton          = DS.singleton+fromSeq            = fromSeqUsingFoldr+insert             = DS.insert+insertSeq          = insertSeqUsingUnion+union              = DS.union+unionSeq seq       = DS.unions (S.toList seq)+delete             = DS.delete+deleteAll          = DS.delete -- by set property+deleteSeq          = deleteSeqUsingDelete+null               = DS.null+size               = DS.size+member             = DS.member+count              = countUsingMember+strict xs          = DS.fold (flip const) () xs `seq` xs++toSeq              = toSeqUsingFold+lookup el set      = DS.findMin (DS.intersection set (DS.singleton el))+lookupM            = lookupMUsingLookupAll+lookupAll el set   = toSeqUsingFold (DS.intersection set (DS.singleton el))+lookupWithDefault  = lookupWithDefaultUsingLookupAll+fold               = DS.fold+fold' f x xs       = L.foldl' (flip f) x (DS.toList xs)+fold1 f set        = let (x,s) = DS.deleteFindMin set in DS.fold f x s+fold1' f xs        = L.foldl1' (flip f) (DS.toList xs)+filter             = DS.filter+partition          = DS.partition+strictWith f xs    = DS.fold (\x z -> f x `seq` z) () xs `seq` xs++deleteMin          = DS.deleteMin+deleteMax          = DS.deleteMax+unsafeInsertMin    = DS.insert+unsafeInsertMax    = DS.insert+unsafeFromOrdSeq   = DS.fromDistinctAscList . S.toList+unsafeAppend       = DS.union+filterLT x         = fst . DS.split x+filterLE x         = DS.filter (<=x)+filterGT x         = snd . DS.split x+filterGE x         = DS.filter (>=x)+partitionLT_GE x   = DS.partition (<x)+partitionLE_GT x   = DS.partition (<=x)+partitionLT_GT     = DS.split++minView set        = if DS.null set +                        then fail (moduleName ++ ".minView: failed")+                        else return (DS.deleteFindMin set)+minElem            = DS.findMin++maxView set        = if DS.null set+                        then fail (moduleName ++ ".maxView: failed")+                        else return (DS.deleteFindMax set)+maxElem            = DS.findMax++foldr   f x set     = L.foldr   f x (DS.toAscList set)+foldr'  f x set     = L.foldr'  f x (DS.toAscList set)+foldr1  f   set     = L.foldr1  f   (DS.toAscList set)+foldr1' f   set     = L.foldr1' f   (DS.toAscList set)+foldl   f x set     = L.foldl   f x (DS.toAscList set)+foldl'  f x set     = L.foldl'  f x (DS.toAscList set)+foldl1  f   set     = L.foldl1  f   (DS.toAscList set)+foldl1' f   set     = L.foldl1' f   (DS.toAscList set)++toOrdSeq           = S.fromList . DS.toAscList++intersection       = DS.intersection+difference         = DS.difference+symmetricDifference = symmetricDifferenceUsingDifference+properSubset       = DS.isProperSubsetOf+subset             = DS.isSubsetOf++fromSeqWith        = fromSeqWithUsingInsertWith+insertWith f x set = case lookupM x set of +                        Nothing -> DS.insert x set+                        Just x' -> DS.insert (f x x') set+insertSeqWith      = insertSeqWithUsingInsertWith+unionl             = DS.union+unionr             = flip DS.union+unionWith          = unionWithUsingOrdLists+unionSeqWith       = unionSeqWithUsingReducer+intersectionWith   = intersectionWithUsingOrdLists+unsafeMapMonotonic = DS.mapMonotonic++++instance Ord a => C.CollX (Set a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Set a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Set a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance Ord a => C.OrdColl (Set a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;+   foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic }++instance Ord a => C.SetX (Set a) a where+  {intersection = intersection; difference = difference;+   symmetricDifference = symmetricDifference;+   properSubset = properSubset; subset = subset}++instance Ord a => C.Set (Set a) a where+  {fromSeqWith = fromSeqWith; insertWith = insertWith; +   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;+   unionWith = unionWith; unionSeqWith = unionSeqWith;+   intersectionWith = intersectionWith}++instance Ord a => C.OrdSetX (Set a) a++instance Ord a => C.OrdSet (Set a) a+++instance (Ord a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = do xs <- arbitrary+                 return (Prelude.foldr insert empty xs)++  coarbitrary set = coarbitrary (C.toList set)
+ src/Data/Edison/Coll/UnbalancedSet.hs view
@@ -0,0 +1,439 @@+-- |+--   Module      :  Data.Edison.Coll.UnbalancedSet+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Sets implemented as unbalanced binary search trees.++module Data.Edison.Coll.UnbalancedSet (+    -- * Set type+    Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX++    -- * CollX operations+    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,+    deleteSeq,null,size,member,count,strict,structuralInvariant,++    -- * Coll operations+    toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',+    fold1,fold1',filter,partition,strictWith,++    -- * OrdCollX operations+    deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,+    unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,+    partitionLE_GT,partitionLT_GT,++    -- * OrdColl operations+    minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',+    foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,++    -- * SetX operations+    intersection,difference,symmetricDifference,properSubset,subset,++    -- * Set operations+    fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,+    unionSeqWith,intersectionWith,++    -- * Documentation+    moduleName+) where++import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)+import qualified Prelude+import Data.Edison.Prelude+import qualified Data.Edison.Coll as C+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Coll.Defaults+import Data.Monoid+import Test.QuickCheck++-- signatures for exported functions+moduleName :: String+empty      :: Set a+singleton  :: a -> Set a+fromSeq    :: (Ord a,S.Sequence seq) => seq a -> Set a+insert     :: Ord a => a -> Set a -> Set a+insertSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a+union      :: Ord a => Set a -> Set a -> Set a+unionSeq   :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a+delete     :: Ord a => a -> Set a -> Set a+deleteAll  :: Ord a => a -> Set a -> Set a+deleteSeq  :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a+null       :: Set a -> Bool+size       :: Set a -> Int+member     :: Ord a => a -> Set a -> Bool+count      :: Ord a => a -> Set a -> Int+strict     :: Set a -> Set a++toSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a+lookup     :: Ord a => a -> Set a -> a+lookupM    :: (Ord a,Monad m) => a -> Set a -> m a+lookupAll  :: (Ord a,S.Sequence seq) => a -> Set a -> seq a+lookupWithDefault :: Ord a => a -> a -> Set a -> a+fold       :: (a -> b -> b) -> b -> Set a -> b+fold1      :: (a -> a -> a) -> Set a -> a+fold'      :: (a -> b -> b) -> b -> Set a -> b+fold1'     :: (a -> a -> a) -> Set a -> a+filter     :: Ord a => (a -> Bool) -> Set a -> Set a+partition  :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)+strictWith :: (a -> b) -> Set a -> Set a++deleteMin        :: Ord a => Set a -> Set a+deleteMax        :: Ord a => Set a -> Set a+unsafeInsertMin  :: Ord a => a -> Set a -> Set a+unsafeInsertMax  :: Ord a => a -> Set a -> Set a+unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a+unsafeAppend     :: Ord a => Set a -> Set a -> Set a+filterLT         :: Ord a => a -> Set a -> Set a+filterLE         :: Ord a => a -> Set a -> Set a+filterGT         :: Ord a => a -> Set a -> Set a+filterGE         :: Ord a => a -> Set a -> Set a+partitionLT_GE   :: Ord a => a -> Set a -> (Set a, Set a)+partitionLE_GT   :: Ord a => a -> Set a -> (Set a, Set a)+partitionLT_GT   :: Ord a => a -> Set a -> (Set a, Set a)++minView       :: (Monad m) => Set a -> m (a, Set a)+minElem       :: Set a -> a+maxView       :: (Monad m) => Set a -> m (a, Set a)+maxElem       :: Set a -> a+foldr         :: (a -> b -> b) -> b -> Set a -> b+foldl         :: (b -> a -> b) -> b -> Set a -> b+foldr1        :: (a -> a -> a) -> Set a -> a+foldl1        :: (a -> a -> a) -> Set a -> a+foldr'        :: (a -> b -> b) -> b -> Set a -> b+foldl'        :: (b -> a -> b) -> b -> Set a -> b+foldr1'       :: (a -> a -> a) -> Set a -> a+foldl1'       :: (a -> a -> a) -> Set a -> a+toOrdSeq      :: (Ord a,S.Sequence seq) => Set a -> seq a++intersection  :: Ord a => Set a -> Set a -> Set a+difference    :: Ord a => Set a -> Set a -> Set a+symmetricDifference :: Ord a => Set a -> Set a -> Set a+properSubset  :: Ord a => Set a -> Set a -> Bool+subset        :: Ord a => Set a -> Set a -> Bool++fromSeqWith   :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a+insertWith    :: Ord a => (a -> a -> a) -> a -> Set a -> Set a+insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a+unionl       :: Ord a => Set a -> Set a -> Set a+unionr       :: Ord a => Set a -> Set a -> Set a+unionWith    :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a+unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a+intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a+unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a++moduleName = "Data.Edison.Coll.UnbalancedSet"++data Set a = E | T (Set a) a (Set a)++-- invariants:+--   * Binary Search Tree order+structuralInvariant :: Ord a => Set a -> Bool+structuralInvariant t = bounded Nothing Nothing t+   where bounded _ _ E = True+         bounded lo hi (T l x r)  = cmp_l lo x +                                 && cmp_r x hi+                                 && bounded lo (Just x) l+                                 && bounded (Just x) hi r++         cmp_l Nothing  _ = True+         cmp_l (Just x) y = x < y++         cmp_r _ Nothing  = True+         cmp_r x (Just y) = x < y++++empty = E+singleton x = T E x E++insertWith c x = ins+  where ins E = T E x E+        ins (T a y b) =+          case compare x y of+            LT -> T (ins a) y b+            EQ -> T a (c x y) b+            GT -> T a y (ins b)++delete x E = E+delete x (T a y b) =+  case compare x y of+    LT -> T (delete x a) y b+    EQ -> unsafeAppend a b+    GT -> T a y (delete x b)++null E = True+null (T _ _ _) = False++size t = sz t 0+  where sz E i = i+        sz (T a x b) i = sz a (sz b (i+1))++member x E = False+member x (T a y b) =+  case compare x y of+    LT -> member x a+    EQ -> True+    GT -> member x b++lookupM x E = fail "UnbalancedSet.lookupM: XXX"+lookupM x (T a y b) =+  case compare x y of+    LT -> lookupM x a+    EQ -> return y+    GT -> lookupM x b++fold f e E = e+fold f e (T a x b) = f x (fold f (fold f e a) b)++fold' f e E = e+fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b)++fold1 f E = error "UnbalancedSet.fold1: empty collection"+fold1 f (T a x b) = fold f (fold f x a) b++fold1' f E = error "UnbalancedSet.fold1': empty collection"+fold1' f (T a x b) = fold' f (fold' f x a) b++deleteMin E = E+deleteMin (T E x b) = b+deleteMin (T a x b) = T (deleteMin a) x b++deleteMax E = E+deleteMax (T a x E) = a+deleteMax (T a x b) = T a x (deleteMax b)++unsafeInsertMin x t = T E x t+unsafeInsertMax x t = T t x E++unsafeFromOrdSeq xs = fst (ins xs (S.size xs))+  where ins xs 0 = (E,xs)+        ins xs n = let m = n `div` 2+                       (a,xs') = ins xs m+                       Just (x,xs'') = S.lview xs'+                       (b,xs''') = ins xs'' (n - m - 1)+                   in (T a x b,xs''')++unsafeAppend a b = case minView b of+                     Nothing -> a+                     Just (x,b') -> T a x b'++filterLT y E = E+filterLT y (T a x b) =+  case compare x y of+    LT -> T a x (filterLT y b)+    EQ -> a+    GT -> filterLT y a++filterLE y E = E+filterLE y (T a x b) =+  case compare x y of+    LT -> T a x (filterLE y b)+    EQ -> T a x E+    GT -> filterLE y a++filterGT y E = E+filterGT y (T a x b) =+  case compare x y of+    LT -> filterGT y b+    EQ -> b+    GT -> T (filterGT y a) x b++filterGE y E = E+filterGE y (T a x b) =+  case compare x y of+    LT -> filterGE y b+    EQ -> T E x b+    GT -> T (filterGE y a) x b++partitionLT_GE y E = (E,E)+partitionLT_GE y (T a x b) =+  case compare x y of+    LT -> (T a x b0,b1)+          where (b0,b1) = partitionLT_GE y b+    EQ -> (a,T E x b)+    GT -> (a0,T a1 x b)+          where (a0,a1) = partitionLT_GE y a++partitionLE_GT y E = (E,E)+partitionLE_GT y (T a x b) =+  case compare x y of+    LT -> (T a x b0,b1)+          where (b0,b1) = partitionLE_GT y b+    EQ -> (T a x E,b)+    GT -> (a0,T a1 x b)+          where (a0,a1) = partitionLE_GT y a++partitionLT_GT y E = (E,E)+partitionLT_GT y (T a x b) =+  case compare x y of+    LT -> (T a x b0,b1)+          where (b0,b1) = partitionLT_GT y b+    EQ -> (a,b)+    GT -> (a0,T a1 x b)+          where (a0,a1) = partitionLT_GT y a++minView E = fail "UnbalancedSet.minView: empty collection"+minView (T E x b) = return (x, b)+minView (T a x b) = return (y, T a' x b)+  where Just (y,a') = minView a++minElem E = error "UnbalancedSet.minElem: empty collection"+minElem (T E x b) = x+minElem (T a x b) = minElem a++maxView E = fail "UnbalancedSet.maxView: empty collection"+maxView (T a x E) = return (x, a)+maxView (T a x b) = return (y, T a x b')+  where Just (y, b') = maxView b++maxElem E = error "UnbalancedSet.maxElem: empty collection"+maxElem (T a x E) = x+maxElem (T a x b) = maxElem b++foldr f e E = e+foldr f e (T a x b) = foldr f (f x (foldr f e b)) a++foldr' f e E = e+foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a++foldl f e E = e+foldl f e (T a x b) = foldl f (f (foldl f e a) x) b++foldl' f e E = e+foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b++foldr1 f E = error "UnbalancedSet.foldr1: empty collection"+foldr1 f (T a x E) = foldr f x a+foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a++foldr1' f E = error "UnbalancedSet.foldr1': empty collection"+foldr1' f (T a x E) = foldr' f x a+foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a++foldl1 f E = error "UnbalancedSet.foldl1: empty collection"+foldl1 f (T E x b) = foldl f x b+foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b++foldl1' f E = error "UnbalancedSet.foldl1': empty collection"+foldl1' f (T E x b) = foldl' f x b+foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b++unsafeMapMonotonic f E = E+unsafeMapMonotonic f (T a x b) = +    T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)++strict s@E = s+strict s@(T l x r) = strict l `seq` strict r `seq` s++strictWith f s@E = s+strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s++-- the remaining functions all use default definitions++fromSeq = fromSeqUsingUnionSeq+insert = insertUsingInsertWith+insertSeq = insertSeqUsingUnion+union = unionUsingUnionWith+unionSeq = unionSeqUsingReduce+deleteAll = delete+deleteSeq = deleteSeqUsingDelete+count = countUsingMember++toSeq = toSeqUsingFold+lookup = lookupUsingLookupM+lookupAll = lookupAllUsingLookupM+lookupWithDefault = lookupWithDefaultUsingLookupM+filter = filterUsingOrdLists+partition = partitionUsingOrdLists+toOrdSeq = toOrdSeqUsingFoldr++intersection = intersectionUsingIntersectionWith+difference = differenceUsingOrdLists+symmetricDifference = symmetricDifferenceUsingDifference+properSubset = properSubsetUsingOrdLists+subset = subsetUsingOrdLists+fromSeqWith = fromSeqWithUsingInsertWith+insertSeqWith = insertSeqWithUsingInsertWith+unionl = unionlUsingUnionWith+unionr = unionrUsingUnionWith+unionWith = unionWithUsingOrdLists+unionSeqWith = unionSeqWithUsingReducer+intersectionWith = intersectionWithUsingOrdLists++-- instance declarations++instance Ord a => C.CollX (Set a) a where+  {singleton = singleton; fromSeq = fromSeq; insert = insert;+   insertSeq = insertSeq; unionSeq = unionSeq; +   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;+   null = null; size = size; member = member; count = count;+   strict = strict;+   structuralInvariant = structuralInvariant; instanceName c = moduleName}++instance Ord a => C.OrdCollX (Set a) a where+  {deleteMin = deleteMin; deleteMax = deleteMax; +   unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; +   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; +   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; +   filterGE = filterGE; partitionLT_GE = partitionLT_GE; +   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}++instance Ord a => C.Coll (Set a) a where+  {toSeq = toSeq; lookup = lookup; lookupM = lookupM; +   lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; +   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   filter = filter; partition = partition; strictWith = strictWith}++instance Ord a => C.OrdColl (Set a) a where+  {minView = minView; minElem = minElem; maxView = maxView; +   maxElem = maxElem; foldr = foldr; foldr' = foldr'; +   foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';+   foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;+   unsafeMapMonotonic = unsafeMapMonotonic}++instance Ord a => C.SetX (Set a) a where+  {intersection = intersection; difference = difference;+   symmetricDifference = symmetricDifference;+   properSubset = properSubset; subset = subset}++instance Ord a => C.Set (Set a) a where+  {fromSeqWith = fromSeqWith; insertWith = insertWith; +   insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;+   unionWith = unionWith; unionSeqWith = unionSeqWith;+   intersectionWith = intersectionWith}++instance Ord a => C.OrdSetX (Set a) a++instance Ord a => C.OrdSet (Set a) a+++instance Ord a => Eq (Set a) where+  xs == ys = C.toOrdList xs == C.toOrdList ys++instance (Ord a, Show a) => Show (Set a) where+   showsPrec = showsPrecUsingToList++instance (Ord a, Read a) => Read (Set a) where+   readsPrec = readsPrecUsingFromList+++instance (Ord a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = do xs <- arbitrary+                 return (Prelude.foldr insert empty xs)++  coarbitrary E = variant 0+  coarbitrary (T a x b) = +    variant 1 . coarbitrary a . coarbitrary x . coarbitrary b++instance (Ord a) => Monoid (Set a) where+    mempty  = empty+    mappend = union+    mconcat = unionSeq++instance (Ord a) => Ord (Set a) where+    compare = compareUsingToOrdList
+ src/Data/Edison/Concrete/FingerTree.hs view
@@ -0,0 +1,773 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Edison.Concrete.FingerTree+-- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006+-- License     :  BSD-style+-- Maintainer  :  robdockins AT fastmail DOT fm+-- Stability   :  internal (non-stable)+-- Portability :  non-portable (MPTCs and functional dependencies)+--+-- A general sequence representation with arbitrary annotations, for+-- use as a base for implementations of various collection types, as+-- described in section 4 of+--+--    * Ralf Hinze and Ross Paterson,+--      \"Finger trees: a simple general-purpose data structure\",+--      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--+-- This data structure forms the basis of the "Data.Edison.Seq.FingerSeq"+-- sequence data structure.+--+-- An amortized running time is given for each operation, with /n/+-- referring to the length of the sequence.  These bounds hold even in+-- a persistent (shared) setting.+--+-----------------------------------------------------------------------------++{------------------------------------------------------------------++Copyright 2004, The University Court of the University of Glasgow. +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 name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE 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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.++-----------------------------------------------------------------------------}+++module Data.Edison.Concrete.FingerTree (+        FingerTree,+        Split(..),++        empty, singleton, lcons, rcons, append,+        fromList, toList, null, size, lview, rview,+        split, takeUntil, dropUntil, splitTree,+        reverse, mapTree, foldFT, reduce1, reduce1',+        strict, strictWith, structuralInvariant++        -- traverse'+        ) where++import Prelude hiding (null, reverse)+import Data.Monoid+import Test.QuickCheck++import Data.Edison.Prelude+++infixr 5 `lcons`+infixl 5 `rcons0`++data Digit a+        = One a+        | Two a a+        | Three a a a+        | Four a a a a+        deriving Show++foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b+foldDigit mapp f (One a) = f a+foldDigit mapp f (Two a b) = f a `mapp` f b+foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c+foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d++reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b+reduceDigit mapp f (One a) = f a+reduceDigit mapp f (Two a b) = f a `mapp` f b+reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c+reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d)++digitToList :: Digit a -> [a] -> [a]+digitToList (One a)        xs = a : xs+digitToList (Two a b)      xs = a : b : xs+digitToList (Three a b c)  xs = a : b : c : xs+digitToList (Four a b c d) xs = a : b : c : d : xs++sizeDigit :: (a -> Int) -> Digit a -> Int+sizeDigit f (One x)        = f x+sizeDigit f (Two x y)      = f x + f y+sizeDigit f (Three x y z)  = f x + f y + f z+sizeDigit f (Four x y z w) = f x + f y + f z + f w++instance (Measured v a) => Measured v (Digit a) where+        measure = foldDigit mappend measure++data Node v a = Node2 !v a a | Node3 !v a a a+        deriving Show++sizeNode :: (a -> Int) -> Node v a -> Int+sizeNode f (Node2 _ x y)   = f x + f y+sizeNode f (Node3 _ x y z) = f x + f y + f z++foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b+foldNode mapp f (Node2 _ a b)   = f a `mapp` f b+foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c++nodeToList :: Node v a -> [a] -> [a]+nodeToList (Node2 _ a b)   xs = a : b : xs+nodeToList (Node3 _ a b c) xs = a : b : c : xs++node2        ::  (Measured v a) => a -> a -> Node v a+node2 a b    =   Node2 (measure a `mappend` measure b) a b++node3        ::  (Measured v a) => a -> a -> a -> Node v a+node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c++instance (Monoid v) => Measured v (Node v a) where+        measure (Node2 v _ _)    =  v+        measure (Node3 v _ _ _)  =  v++nodeToDigit :: Node v a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c+++-- | Finger trees with element type @a@, annotated with measures of type @v@.+-- The operations enforce the constraint @'Measured' v a@.+data FingerTree v a+        = Empty+        | Single a+        | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)++deep ::  (Measured v a) =>+         Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a+deep pr m sf  =   Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf++structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool+structuralInvariant Empty      = True+structuralInvariant (Single _) = True+structuralInvariant (Deep v pr m sf) =+     v == foldDigit mappend measure pr `mappend`+          foldFT    mempty mappend (foldNode mappend measure) m `mappend`+          foldDigit mappend measure sf++instance (Measured v a) => Measured v (FingerTree v a) where+        measure Empty           =  mempty+        measure (Single x)      =  measure x+        measure (Deep v _ _ _)  =  v++sizeFT :: (a -> Int) -> FingerTree v a -> Int+sizeFT f Empty            = 0+sizeFT f (Single x)       = f x+sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2++size :: FingerTree v a -> Int+size = sizeFT (const 1)++foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b+foldFT mz mapp _ Empty      = mz+foldFT mz mapp f (Single x) = f x+foldFT mz mapp f (Deep _ pr m sf) =+             foldDigit  mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf++ftToList :: FingerTree v a -> [a] -> [a]+ftToList Empty xs             = xs+ftToList (Single a) xs        = a : xs+ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs)++toList :: FingerTree v a -> [a]+toList ft = ftToList ft []++reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b+reduce1_aux mapp f pr Empty sf = +     (reduceDigit mapp f pr) `mapp`+     (reduceDigit mapp f sf)++reduce1_aux mapp f pr (Single x) sf =+     (reduceDigit mapp f pr) `mapp`+     (foldNode mapp f x)     `mapp`+     (reduceDigit mapp f sf)++reduce1_aux mapp f pr (Deep _ pr' m sf') sf =+     (reduceDigit mapp f pr) `mapp` +     (reduce1_aux mapp+        (foldNode mapp f)+            pr' m sf')       `mapp`+     (reduceDigit mapp f sf)++reduce1 :: (a -> a -> a) -> FingerTree v a -> a+reduce1 mapp Empty             = error "FingerTree.reduce1: empty tree"+reduce1 mapp (Single x)        = x+reduce1 mapp (Deep _ pr m sf)  = reduce1_aux mapp id pr m sf++reduce1' :: (a -> a -> a) -> FingerTree v a -> a +reduce1' mapp Empty            = error "FingerTree.reduce1': empty tree"+reduce1' mapp (Single x)       = x+reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf+  where mapp' x y = x `seq` y `seq` mapp x y+++strict :: FingerTree v a -> FingerTree v a+strict xs = foldFT () seq (const ()) xs `seq` xs++strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a+strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs++instance (Measured v a, Eq a) => Eq (FingerTree v a) where+        xs == ys = toList xs == toList ys++instance (Measured v a, Ord a) => Ord (FingerTree v a) where+        compare xs ys = compare (toList xs) (toList ys)++instance (Measured v a, Show a) => Show (FingerTree v a) where+        showsPrec p xs = showParen (p > 10) $+                showString "fromList " . shows (toList xs)++mapTree :: (Measured v2 a2) =>+        (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2+mapTree _ Empty = Empty+mapTree f (Single x) = Single (f x)+mapTree f (Deep _ pr m sf) =+        deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)++mapNode :: (Measured v2 a2) =>+        (a1 -> a2) -> Node v1 a1 -> Node v2 a2+mapNode f (Node2 _ a b) = node2 (f a) (f b)+mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)++mapDigit :: (a -> b) -> Digit a -> Digit b+mapDigit f (One a) = One (f a)+mapDigit f (Two a b) = Two (f a) (f b)+mapDigit f (Three a b c) = Three (f a) (f b) (f c)+mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)+++{-+-- | Like 'traverse', but with a more constrained type.+traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>+        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverse' = traverseTree++traverseTree :: (Measured v2 a2, Applicative f) =>+        (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)+traverseTree _ Empty = pure Empty+traverseTree f (Single x) = Single <$> f x+traverseTree f (Deep _ pr m sf) =+        deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf++traverseNode :: (Measured v2 a2, Applicative f) =>+        (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)+traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b+traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c++traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)+traverseDigit f (One a) = One <$> f a+traverseDigit f (Two a b) = Two <$> f a <*> f b+traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c+traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d+-}++-- | /O(1)/. The empty sequence.+empty :: Measured v a => FingerTree v a+empty = Empty++-- | /O(1)/. A singleton sequence.+singleton :: Measured v a => a -> FingerTree v a+singleton = Single++-- | /O(n)/. Create a sequence from a finite list of elements.+fromList :: (Measured v a) => [a] -> FingerTree v a+fromList = foldr lcons Empty++-- | /O(1)/. Add an element to the left end of a sequence.+lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a+a `lcons` Empty         =  Single a+a `lcons` Single b              =  deep (One a) Empty (One b)+a `lcons` Deep _ (Four b c d e) m sf = m `seq`+        deep (Two a b) (node3 c d e `lcons` m) sf+a `lcons` Deep _ pr m sf        =  deep (consDigit a pr) m sf++consDigit :: a -> Digit a -> Digit a+consDigit a (One b) = Two a b+consDigit a (Two b c) = Three a b c+consDigit a (Three b c d) = Four a b c d+consDigit _ _ = error "FingerTree.consDigit: bug!"++-- | /O(1)/. Add an element to the right end of a sequence.+rcons ::  (Measured v a) => a -> FingerTree v a -> FingerTree v a+rcons = flip rcons0++rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a+Empty `rcons0` a                =  Single a+Single a `rcons0` b             =  deep (One a) Empty (One b)+Deep _ pr m (Four a b c d) `rcons0` e = m `seq`+        deep pr (m `rcons0` node3 a b c) (Two d e)+Deep _ pr m sf `rcons0` x       =  deep pr m (snocDigit sf x)++snocDigit :: Digit a -> a -> Digit a+snocDigit (One a) b = Two a b+snocDigit (Two a b) c = Three a b c+snocDigit (Three a b c) d = Four a b c d+snocDigit _ _ = error "FingerTree.snocDigit: bug!"++-- | /O(1)/. Is this the empty sequence?+null :: (Measured v a) => FingerTree v a -> Bool+null Empty = True+null _ = False++-- | /O(1)/. Analyse the left end of a sequence.+lview :: (Measured v a, Monad m) => FingerTree v a -> m (a,FingerTree v a)+lview Empty                 =  fail "FingerTree.lview: empty tree"+lview (Single x)            =  return (x, Empty)+lview (Deep _ (One x) m sf) =  return . (,) x $+        case lview m of+          Nothing     -> digitToTree sf+          Just (a,m') -> deep (nodeToDigit a) m' sf++lview (Deep _ pr m sf)      =  return (lheadDigit pr, deep (ltailDigit pr) m sf)++lheadDigit :: Digit a -> a+lheadDigit (One a) = a+lheadDigit (Two a _) = a+lheadDigit (Three a _ _) = a+lheadDigit (Four a _ _ _) = a++ltailDigit :: Digit a -> Digit a+ltailDigit (Two _ b) = One b+ltailDigit (Three _ b c) = Two b c+ltailDigit (Four _ b c d) = Three b c d+ltailDigit _ = error "FingerTree.ltailDigit: bug!"++-- | /O(1)/. Analyse the right end of a sequence.+rview :: (Measured v a, Monad m) => FingerTree v a -> m (a, FingerTree v a)+rview Empty                  = fail "FingerTree.rview: empty tree"+rview (Single x)             = return (x, Empty)+rview (Deep _ pr m (One x))  = return . (,) x $+        case rview m of+           Nothing      -> digitToTree pr+           Just (a,m')  -> deep pr m' (nodeToDigit a)++rview (Deep _ pr m sf)       =  return (rheadDigit sf, deep pr m (rtailDigit sf))+++rheadDigit :: Digit a -> a+rheadDigit (One a) = a+rheadDigit (Two _ b) = b+rheadDigit (Three _ _ c) = c+rheadDigit (Four _ _ _ d) = d++rtailDigit :: Digit a -> Digit a+rtailDigit (Two a _) = One a+rtailDigit (Three a b _) = Two a b+rtailDigit (Four a b c _) = Three a b c+rtailDigit _ = error "FingerTree.rtailDigit: bug!"++digitToTree :: (Measured v a) => Digit a -> FingerTree v a+digitToTree (One a) = Single a+digitToTree (Two a b) = deep (One a) Empty (One b)+digitToTree (Three a b c) = deep (Two a b) Empty (One c)+digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)+++-- | /O(log(min(n1,n2)))/. Concatenate two sequences.+append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a+append =  appendTree0++appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a+appendTree0 Empty xs =+        xs+appendTree0 xs Empty =+        xs+appendTree0 (Single x) xs =+        x `lcons` xs+appendTree0 xs (Single x) =+        xs `rcons0` x+appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =+        deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2++addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)+addDigits0 m1 (One a) (One b) m2 =+        appendTree1 m1 (node2 a b) m2+addDigits0 m1 (One a) (Two b c) m2 =+        appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (One a) (Three b c d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (One a) (Four b c d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (One c) m2 =+        appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (Two a b) (Two c d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Two a b) (Three c d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (Four c d e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (One d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Three a b c) (Two d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Three a b c) (Three d e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (Four d e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (One e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Four a b c d) (Two e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Four a b c d) (Three e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2++appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a+appendTree1 Empty a xs =+        a `lcons` xs+appendTree1 xs a Empty =+        xs `rcons0` a+appendTree1 (Single x) a xs =+        x `lcons` (a `lcons` xs)+appendTree1 xs a (Single x) =+        xs `rcons0` a `rcons0` x+appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =+        deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2++addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)+addDigits1 m1 (One a) b (One c) m2 =+        appendTree1 m1 (node3 a b c) m2+addDigits1 m1 (One a) b (Two c d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (One a) b (Three c d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (One a) b (Four c d e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (One d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (Two a b) c (Two d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Two a b) c (Three d e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (Four d e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (One e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Three a b c) d (Two e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Three a b c) d (Three e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (One f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Four a b c d) e (Two f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2++appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a+appendTree2 Empty a b xs =+        a `lcons` (b `lcons` xs)+appendTree2 xs a b Empty =+        xs `rcons0` a `rcons0` b+appendTree2 (Single x) a b xs =+        x `lcons` (a `lcons` (b `lcons` xs))+appendTree2 xs a b (Single x) =+        xs `rcons0` a `rcons0` b `rcons0` x+appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =+        deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2++addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)+addDigits2 m1 (One a) b c (One d) m2 =+        appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits2 m1 (One a) b c (Two d e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (One a) b c (Three d e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (One a) b c (Four d e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (One e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (Two a b) c d (Two e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Two a b) c d (Three e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (One f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Three a b c) d e (Two f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (One g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2++appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a+appendTree3 Empty a b c xs =+        a `lcons` (b `lcons` (c `lcons` xs))+appendTree3 xs a b c Empty =+        xs `rcons0` a `rcons0` b `rcons0` c+appendTree3 (Single x) a b c xs =+        x `lcons` (a `lcons` (b `lcons` (c `lcons` xs)))+appendTree3 xs a b c (Single x) =+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x+appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =+        deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2++addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)+addDigits3 m1 (One a) b c d (One e) m2 =+        appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits3 m1 (One a) b c d (Two e f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (One a) b c d (Three e f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (One a) b c d (Four e f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (One f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (Two a b) c d e (Two f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (One g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (One h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2++appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a+appendTree4 Empty a b c d xs =+        a `lcons` b `lcons` c `lcons` d `lcons` xs+appendTree4 xs a b c d Empty =+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d+appendTree4 (Single x) a b c d xs =+        x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs+appendTree4 xs a b c d (Single x) =+        xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x+appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =+        deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2++addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)+addDigits4 m1 (One a) b c d e (One f) m2 =+        appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits4 m1 (One a) b c d e (Two f g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (One a) b c d e (Three f g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (One g) m2 =+        appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (One h) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =+        appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =+        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2+++-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate+-- on the accumulated measure changes from 'False' to 'True'.+split ::  (Measured v a) =>+          (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)+split _p Empty  =  (Empty, Empty)+split p xs+  | p (measure xs) =  (l, x `lcons` r)+  | otherwise   =  (xs, Empty)+  where Split l x r = splitTree p mempty xs++takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a+takeUntil p  =  fst . split p++dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a+dropUntil p  =  snd . split p++data Split t a = Split t a t++splitTree ::    (Measured v a) =>+                (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a+splitTree _ _ Empty = error "FingerTree.splitTree: bug!"+splitTree _p _i (Single x) = Split Empty x Empty+splitTree p i (Deep _ pr m sf)+  | p vpr       =  let  Split l x r     =  splitDigit p i pr+                   in   Split (maybe Empty digitToTree l) x (deepL r m sf)+  | p vm        =  let  Split ml xs mr  =  splitTree p vpr m+                        Split l x r     =  splitNode p (vpr `mappendVal` ml) xs+                   in   Split (deepR pr  ml l) x (deepL r mr sf)+  | otherwise   =  let  Split l x r     =  splitDigit p vm sf+                   in   Split (deepR pr  m  l) x (maybe Empty digitToTree r)+  where vpr     =  i    `mappend`  measure pr+        vm      =  vpr  `mappendVal` m++mappendVal :: (Measured v a) => v -> FingerTree v a -> v+mappendVal v Empty = v+mappendVal v t = v `mappend` measure t++deepL          ::  (Measured v a) =>+        Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a+deepL Nothing m sf      =   case lview m of+        Nothing     ->  digitToTree sf+        Just (a,m') ->  deep (nodeToDigit a) m' sf+deepL (Just pr) m sf    =   deep pr m sf++deepR          ::  (Measured v a) =>+        Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a+deepR pr m Nothing      =   case rview m of+        Nothing     ->  digitToTree pr+        Just (a,m') ->  deep pr m' (nodeToDigit a)+deepR pr m (Just sf)    =   deep pr m sf++splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->+                Split (Maybe (Digit a)) a+splitNode p i (Node2 _ a b)+  | p va        = Split Nothing a (Just (One b))+  | otherwise   = Split (Just (One a)) b Nothing+  where va      = i `mappend` measure a+splitNode p i (Node3 _ a b c)+  | p va        = Split Nothing a (Just (Two b c))+  | p vab       = Split (Just (One a)) b (Just (One c))+  | otherwise   = Split (Just (Two a b)) c Nothing+  where va      = i `mappend` measure a+        vab     = va `mappend` measure b++splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->+                Split (Maybe (Digit a)) a+splitDigit p i (One a) = i `seq` Split Nothing a Nothing+splitDigit p i (Two a b)+  | p va        = Split Nothing a (Just (One b))+  | otherwise   = Split (Just (One a)) b Nothing+  where va      = i `mappend` measure a+splitDigit p i (Three a b c)+  | p va        = Split Nothing a (Just (Two b c))+  | p vab       = Split (Just (One a)) b (Just (One c))+  | otherwise   = Split (Just (Two a b)) c Nothing+  where va      = i `mappend` measure a+        vab     = va `mappend` measure b+splitDigit p i (Four a b c d)+  | p va        = Split Nothing a (Just (Three b c d))+  | p vab       = Split (Just (One a)) b (Just (Two c d))+  | p vabc      = Split (Just (Two a b)) c (Just (One d))+  | otherwise   = Split (Just (Three a b c)) d Nothing+  where va      = i `mappend` measure a+        vab     = va `mappend` measure b+        vabc    = vab `mappend` measure c+++-- | /O(n)/. The reverse of a sequence.+reverse :: (Measured v a) => FingerTree v a -> FingerTree v a+reverse = reverseTree id++reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2+reverseTree _ Empty = Empty+reverseTree f (Single x) = Single (f x)+reverseTree f (Deep _ pr m sf) =+        deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)++reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2+reverseNode f (Node2 _ a b) = node2 (f b) (f a)+reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)++reverseDigit :: (a -> b) -> Digit a -> Digit b+reverseDigit f (One a) = One (f a)+reverseDigit f (Two a b) = Two (f b) (f a)+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++++instance (Arbitrary a) => Arbitrary (Digit a) where+  arbitrary = oneof +              [ arbitrary       >>= \x         -> return (One x)+              , two arbitrary   >>= \(x,y)     -> return (Two x y)+              , three arbitrary >>= \(x,y,z)   -> return (Three x y z)+              , four arbitrary  >>= \(x,y,z,w) -> return (Four x y z w)+              ]++  coarbitrary p = case p of+      One x        -> variant 0 . coarbitrary x+      Two x y      -> variant 1 . coarbitrary x . coarbitrary y+      Three x y z  -> variant 2 . coarbitrary x . coarbitrary y+                      . coarbitrary z+      Four x y z w -> variant 3 . coarbitrary x . coarbitrary y+                      . coarbitrary z . coarbitrary w+++instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where+  arbitrary = oneof+              [ two arbitrary   >>= \(x,y)     -> return (node2 x y)+              , three arbitrary >>= \(x,y,z)   -> return (node3 x y z)+              ]++  coarbitrary p = case p of+       Node2 _ x y   -> variant 0 . coarbitrary x . coarbitrary y+       Node3 _ x y z -> variant 1 . coarbitrary x . coarbitrary y . coarbitrary z+++instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where+  arbitrary = oneof+               [ return Empty+               , arbitrary >>= return . Single+               , do +                   pf <- arbitrary+                   m  <- arbitrary+                   sf <- arbitrary+                   return (deep pf m sf)+               ]++  coarbitrary p = case p of+         Empty          -> variant 0+         Single x       -> variant 1 . coarbitrary x+         Deep _ sf m pf -> variant 2 . coarbitrary sf . coarbitrary m . coarbitrary pf
+ src/Data/Edison/Seq/BankersQueue.hs view
@@ -0,0 +1,419 @@+-- |+--   Module      :  Data.Edison.Seq.BankersQueue+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module implements Banker's Queues. It has the standard running+--   times from "Data.Edison.Seq" except for the following:+--+--   * rcons, size, inBounds   @O( 1 )@+--+--   /References:/+--+--   * Chris Okasaki, /Purely Functional Data Structures/,+--     1998, sections 6.3.2 and 8.4.1.+--+--   * Chris Okasaki, \"Simple and efficient purely functional+--     queues and deques\", /Journal of Function Programming/+--     5(4):583-592, October 1995.++module Data.Edison.Seq.BankersQueue (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName++) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults+import qualified Data.Edison.Seq.ListSeq as L+import Data.Monoid+import Control.Monad+import Control.Monad.Identity+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a++structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.BankersQueue"+++data Seq a = Q !Int [a] [a] !Int++-- invariant: front at least as long as rear+structuralInvariant (Q x f r y) =+    length f == x && length r == y && x >= y+++-- not exported+makeQ :: Int -> [a] -> [a] -> Int -> Seq a+makeQ i xs ys j+  | j > i     = Q (i + j) (xs ++ L.reverse ys) [] 0+  | otherwise = Q i xs ys j++empty = Q 0 [] [] 0+singleton x = Q 1 [x] [] 0+lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j+rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1)++append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =+    Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2++lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence"+lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j)++lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence"+lhead (Q _ (x:xs) _ _) = x++lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence"+lheadM (Q _ (x:xs) _ _) = return x++ltail (Q i (x:xs) ys j) = makeQ (i-1) xs ys j+ltail q = error "BankersQueue.ltail: empty sequence"++ltailM (Q i (x:xs) ys j) = return (makeQ (i-1) xs ys j)+ltailM q = fail "BankersQueue.ltail: empty sequence"++rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1))+rview (Q i xs [] _) =+  case L.rview xs of+    Nothing      -> fail "BankersQueue.rview: empty sequence"+    Just (x,xs') -> return (x, Q (i-1) xs' [] 0)++rhead (Q i xs (y:ys) j) = y+rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence"+rhead (Q i xs [] _) = L.rhead xs++rheadM (Q i xs (y:ys) j) = return y+rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence"+rheadM (Q i xs [] _) = return (L.rhead xs)++rtail (Q i xs (y:ys) j) = Q i xs ys (j-1)+rtail q@(Q _ [] [] _) = error "BankersQueue.rtail: empty sequence"+rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0++rtailM (Q i xs (y:ys) j) = return (Q i xs ys (j-1))+rtailM q@(Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence"+rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0)++null (Q i _ _ _) = (i == 0)+size (Q i xs ys j) = i + j+reverse (Q i xs ys j) = makeQ j ys xs i++reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =+    Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2++fromList xs = Q (length xs) xs [] 0++toList (Q i xs ys j)+  | j == 0 = xs+  | otherwise = xs ++ L.reverse ys++map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j++-- local fn on lists+revfoldr f e [] = e+revfoldr f e (x:xs) = revfoldr f (f x e) xs++revfoldr' f e [] = e+revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs++-- local fn on lists+revfoldl f e [] = e+revfoldl f e (x:xs) = f (revfoldl f e xs) x++revfoldl' f e [] = e+revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs)++fold  f e (Q i xs ys j) = L.foldr f (L.foldr f e ys) xs+fold' f e (Q i xs ys j) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr  f e (Q i xs ys j) = L.foldr  f (revfoldr  f e ys) xs+foldr' f e (Q i xs ys j) = L.foldr' f (revfoldr' f e ys) xs+foldl  f e (Q i xs ys j) = revfoldl  f (L.foldl  f e xs) ys+foldl' f e (Q i xs ys j) = revfoldl' f (L.foldl' f e xs) ys++foldr1 f (Q i xs (y:ys) j) = L.foldr f (revfoldr f y ys) xs+foldr1 f (Q i xs [] _)+  | i == 0 = error "BankersQueue.foldr1: empty sequence"+  | otherwise = L.foldr1 f xs++foldr1' f (Q i xs (y:ys) j) = L.foldr' f (revfoldr' f y ys) xs+foldr1' f (Q i xs [] _)+  | i == 0 = error "BankersQueue.foldr1': empty sequence"+  | otherwise = L.foldr1' f xs++foldl1 f (Q i (x:xs) ys j) = revfoldl f (L.foldl f x xs) ys+foldl1 f _ = error "BankersQueue.foldl1: empty sequence"++foldl1' f (Q i (x:xs) ys j) = revfoldl' f (L.foldl' f x xs) ys+foldl1' f _ = error "BankersQueue.foldl1': empty sequence"++copy n x +  | n < 0     = empty+  | otherwise = Q n (L.copy n x) [] 0++-- reduce1: given sizes could do more effective job of dividing evenly!++lookup idx q = runIdentity (lookupM idx q)++lookupM idx (Q i xs ys j)+  | idx < i   = L.lookupM idx xs+  | otherwise = L.lookupM (j - (idx - i) - 1) ys++lookupWithDefault d idx (Q i xs ys j)+  | idx < i   = L.lookupWithDefault d idx xs+  | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys++update idx e q@(Q i xs ys j)+  | idx < i = if idx < 0 then q+             else Q i (L.update idx e xs) ys j+  | otherwise = let k' = j - (idx - i) - 1+                in if k' < 0 then q+                   else Q i xs (L.update k' e ys) j++adjust f idx q@(Q i xs ys j)+  | idx < i = if idx < 0 then q+             else Q i (L.adjust f idx xs) ys j+  | otherwise = let k' = j - (idx - i) - 1+                in if k' < 0 then q+                   else Q i xs (L.adjust f k' ys) j++{- +could do+  mapWithIndex   :: (Int -> a -> b) -> s a -> s b+  foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b+  foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b+but don't bother for now+-}++take len q@(Q i xs ys j) =+  if len <= i then+    if len <= 0 then empty+    else Q len (L.take len xs) [] 0+  else let len' = len - i in+    if len' >= j then q+    else Q i xs (L.drop (j - len') ys) len'++drop len q@(Q i xs ys j) =+  if len <= i then+    if len <= 0 then q+    else makeQ (i - len) (L.drop len xs) ys j+  else let len' = len - i in+    if len' >= j then empty+    else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0+  -- could write more efficient version of reverse (take ...) ++splitAt idx q@(Q i xs ys j) =+  if idx <= i then+    if idx <= 0 then (empty, q)+    else let (xs',xs'') = L.splitAt idx xs+         in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j)+  else let idx' = idx - i in+    if idx' >= j then (q, empty)+    else let (ys', ys'') = L.splitAt (j - idx') ys+         in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0)+      -- could do splitAt followed by reverse more efficiently...+  ++strict l@(Q i xs ys j) = L.strict xs `seq` L.strict ys `seq` l+strictWith f l@(Q i xs ys j) = L.strictWith f xs `seq` L.strictWith f ys `seq` l++-- the remaining functions all use defaults++concat = concatUsingFoldr+concatMap = concatMapUsingFoldr+reducer = reducerUsingReduce1+reducel = reducelUsingReduce1+reduce1 = reduce1UsingLists+reducer' = reducer'UsingReduce1'+reducel' = reducel'UsingReduce1'+reduce1' = reduce1'UsingLists+inBounds = inBoundsUsingSize+mapWithIndex = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+subseq = subseqDefault+filter = filterUsingLists+partition = partitionUsingLists+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview+zip = zipUsingLists+zip3 = zip3UsingLists+zipWith = zipWithUsingLists+zipWith3 = zipWith3UsingLists+unzip = unzipUsingLists+unzip3 = unzip3UsingLists+unzipWith = unzipWithUsingLists+unzipWith3 = unzipWith3UsingLists++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; +   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer';+   reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Eq a => Eq (Seq a) where+  q1 == q2 =+    (size q1 == size q2) && (toList q1 == toList q2)++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary =+    do xs <- arbitrary+       ys <- arbitrary+       return (let i = L.size xs+                   j = L.size ys+               in if i >= j then Q i xs ys j else Q j ys xs i)++  coarbitrary (Q i xs ys j) = coarbitrary xs . coarbitrary ys++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/BinaryRandList.hs view
@@ -0,0 +1,447 @@+-- |+--   Module      :  Data.Edison.Seq.BinaryRandList+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Binary Random-Access lists.  All functions have the standard running+--   times from "Data.Edison.Seq" except the following:+--+--  * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop   @O( log n )@+--+--  * copy, inBounds   @O( i )@+--+--  * append, reverseOnto  @O( n1 + log n2 )@+--+--  * take, splitAt  @O( i + log n )@+--+--  * subseq         @O( log n + len )@+--+--  * zip            @O( min( n1, n2 ) + log max( n1, n2 ) )@+--+--    /References:/+--+--  * Chris Okasaki. /Purely Functional Data Structures/. 1998.+--    Section 10.1.2.++module Data.Edison.Seq.BinaryRandList (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Control.Monad.Identity+import Data.Maybe++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults+import Data.Monoid+import Control.Monad+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.BinaryRandList"+++data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a))    deriving (Eq)++-- not exported, rewrite as bit ops?+--even n = (n `mod` 2) == 0+--odd n  = (n `mod` 2) <> 0+half n = n `div` 2++mkEven E = E+mkEven ps = Even ps++empty = E+singleton x = Odd x E++lcons x E = Odd x E+lcons x (Even ps) = Odd x ps+lcons x (Odd y ps) = Even (lcons (x,y) ps)++append xs E = xs+append xs ys@(Even pys) =+  case xs of+    E -> ys+    Even pxs -> Even (append pxs pys)+    Odd x pxs -> Odd x (append pxs pys)+append xs ys@(Odd _ _) = foldr lcons ys xs++copy n x +    | n <= 0 = E+    | otherwise = cp n x+  where cp :: Int -> a -> Seq a+        cp n x+          | odd n = Odd x (cp (half n) (x,x))+          | n == 0 = E+          | otherwise = Even (cp (half n) (x,x))++lview E = fail "BinaryRandList.lview: empty sequence"+lview (Even ps) = case lview ps of+                    Just ((x,y), ps') -> return (x, Odd y ps')+                    Nothing -> error "BinaryRandList.lview: bug!"+lview (Odd x ps) = return (x, mkEven ps)++lhead E = error "BinaryRandList.lhead: empty sequence"+lhead (Even ps) = fst (lhead ps)+lhead (Odd x ps) = x++lheadM E = fail "BinaryRandList.lheadM: empty sequence"+lheadM (Even ps) = return (fst (lhead ps))+lheadM (Odd x ps) = return (x)++ltail E = error "BinaryRandList.ltail: empty sequence"+ltail (Even ps) = case lview ps of+                    Just ((x,y), ps') -> Odd y ps'+                    Nothing -> error "BinaryRandList.ltail: bug!"+ltail (Odd x ps) = mkEven ps++ltailM E = fail "BinaryRandList.ltailM: empty sequence"+ltailM (Even ps) = case lview ps of+                      Just ((x,y), ps') -> return (Odd y ps')+                      Nothing -> error "BinaryRandList.ltailM: bug!"+ltailM (Odd x ps) = return (mkEven ps)++rhead E = error "BinaryRandList.rhead: empty sequence"+rhead (Even ps) = snd (rhead ps)+rhead (Odd x E) = x+rhead (Odd x ps) = snd (rhead ps)++rheadM E = fail "BinaryRandList.rheadM: empty sequence"+rheadM (Even ps) = return (snd (rhead ps))+rheadM (Odd x E) = return x+rheadM (Odd x ps) = return (snd (rhead ps))+++null E = True+null _ = False++size E = 0+size (Even ps) = 2 * size ps+size (Odd x ps) = 1 + 2 * size ps++map f E = E+map f (Even ps)  = Even (map (\(x,y) -> (f x,f y)) ps)+map f (Odd x ps) = Odd (f x) (map (\(x,y) -> (f x,f y)) ps)++fold   = foldr+fold'  = foldr'+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr f e E = e+foldr f e (Even ps)  = foldr (\(x,y) e -> f x (f y e)) e ps+foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps)++foldr' f e E = e+foldr' f e (Even ps)  = foldr' (\(x,y) e -> f x $! f y $! e) e ps+foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps)++foldl f e E = e+foldl f e (Even ps)  = foldl (\e (x,y) -> f (f e x) y) e ps+foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps++foldl' f e E = e+foldl' f e (Even ps)  = foldl' (\e (x,y) -> f (f e x) y) e ps+foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps++reduce1 f E = error "BinaryRandList.reduce1: empty seq"+reduce1 f (Even ps)  = reduce1 f (map (uncurry f) ps)+reduce1 f (Odd x E)  = x+reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps))++reduce1' f E = error "BinaryRandList.reduce1': empty seq"+reduce1' f (Even ps)  = reduce1' f (map (uncurry f) ps)+reduce1' f (Odd x E)  = x+reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps))+++inBounds i xs = (i >= 0) && inb xs i+  where inb :: Seq a -> Int -> Bool+        inb E i = False+        inb (Even ps) i = inb ps (half i)+        inb (Odd x ps) i = (i == 0) || inb ps (half (i-1))++lookup i xs = runIdentity (lookupM i xs)++lookupM i xs+    | i < 0     = fail "BinaryRandList.lookup: bad subscript"+    | otherwise = lookFun nothing xs i return+    where+    	nothing = fail "BinaryRandList.lookup: not found"++lookupWithDefault d i xs+    | i < 0 = d+    | otherwise = lookFun d xs i id++-- not exported+lookFun :: b -> Seq a -> Int -> (a -> b) -> b+lookFun d E i f = d+lookFun d (Even ps) i f+  | even i = lookFun d ps (half i) (f . fst)+  | otherwise = lookFun d ps (half i) (f . snd)+lookFun d (Odd x ps) i f+  | odd i = lookFun d ps (half (i-1)) (f . fst)+  | i == 0 = f x+  | otherwise = lookFun d ps (half (i-1)) (f . snd)++adjust f i xs+    | i < 0 = xs+    | otherwise = adj f i xs+  where adj :: (a -> a) -> Int -> Seq a -> Seq a+        adj f i E = E+        adj f i (Even ps)+          | even i = Even (adj (mapFst f) (half i) ps)+          | otherwise = Even (adj (mapSnd f) (half i) ps)+        adj f i (Odd x ps)+          | odd i = Odd x (adj (mapFst f) (half (i-1)) ps)+          | i == 0 = Odd (f x) ps+          | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps)++-- not exported+mapFst f (x,y) = (f x,y)+mapSnd f (x,y) = (x,f y)++take n xs = if n <= 0 then E else tak n xs+  where tak :: Int -> Seq a -> Seq a+        tak 0 xs = E+        tak i E = E+        tak i (Even ps)+          | even i = Even (tak (half i) ps)+        tak i (Odd x ps)+          | odd i = Odd x (tak (half (i-1)) ps)+        tak i xs = takeUsingLists i xs++-- drop is O(log^2 n) instead of O(log n)??+drop n xs = if n <= 0 then xs else drp n xs+  where drp :: Int -> Seq a -> Seq a+        drp 0 xs = xs+        drp i E = E+        drp i (Even ps)+          | even i = mkEven (drp (half i) ps)+          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps)))+        drp i (Odd _ ps)+          | odd i = mkEven (drp (half (i-1)) ps)+          | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps)))+++strict l@E = l+strict l@(Even l') = strict l' `seq` l+strict l@(Odd x l') = strict l' `seq` l++strictWith f l@E = l+strictWith f l@(Even l')  = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l+strictWith f l@(Odd x l') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l+++-- structural invariants are enforced by the type system+structuralInvariant = const True++-- the remaining functions all use defaults++rcons = rconsUsingFoldr+rview = rviewDefault+rtail = rtailUsingLview+rtailM = rtailMUsingLview+concat = concatUsingFoldr+reverse = reverseUsingReverseOnto+reverseOnto = reverseOntoUsingFoldl+fromList = fromListUsingCons+toList = toListUsingFoldr+concatMap = concatMapUsingFoldr+foldr1 = foldr1UsingLview+foldr1' = foldr1'UsingLview+foldl1 = foldl1UsingFoldl+foldl1' = foldl1'UsingFoldl'+reducer = reducerUsingReduce1+reducel = reducelUsingReduce1+reducer' = reducer'UsingReduce1'+reducel' = reducel'UsingReduce1'+update = updateUsingAdjust+mapWithIndex = mapWithIndexUsingLists+foldrWithIndex = foldrWithIndexUsingLists+foldlWithIndex = foldlWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+splitAt = splitAtDefault+filter = filterUsingFoldr+partition = partitionUsingFoldr+subseq = subseqDefault+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview++-- for zips, could optimize by calculating which one is shorter and+-- retaining its shape++zip = zipUsingLists+zip3 = zip3UsingLists+zipWith = zipWithUsingLists+zipWith3 = zipWith3UsingLists+unzip = unzipUsingLists+unzip3 = unzip3UsingLists+unzipWith = unzipWithUsingLists+unzipWith3 = unzipWith3UsingLists++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++-- instance Eq (Seq a) is derived++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = do xs <- arbitrary +                 return (fromList xs)++  coarbitrary E = variant 0+  coarbitrary (Even ps) = variant 1 . coarbitrary ps+  coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/BraunSeq.hs view
@@ -0,0 +1,548 @@+-- |+--   Module      :  Data.Edison.Seq.BraunSeq+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   One-sided Braun sequences.  All running times are as listed in +--   "Data.Edison.Seq" except the following:+--+--   * lview, lcons, ltail*   @O( log n )@+--+--   * rcons, rview, rhead*, rtail*, size   @O( log^2 n )@+--+--   * copy, inBounds, lookup*, update, adjust  @O( log i )@+--+--   * append            @O( n1 log n2 )@+--+--   * concat            @O( n + m log m )@+--+--   * drop, splitAt     @O( i log n )@+--+--   * subseq            @O( i log n + len )@+--+--   * reverseOnto       @O( n1 log n2 )@+--+--   * concatMap, (>>=)  @O( n * t + m log m )@, where @n@ is the length of the input sequence+--                                               @m@ is the length of the output sequence and @t@+--                                               is the running time of @f@+--+--   By keeping track of the size, we could get rcons, rview, rhead*, and rtail*+--   down to @O(log n)@ as well; furthermore, size would be @O( 1 )@.+--+--   /References:/+--+--   * Rob Hoogerwoord. \"A symmetric set of efficient list operations\".+--     /Journal of Functional Programming/, 2(4):505--513, 1992.+--+--   * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\".+--     /Mathematics of Program Construction/ (MPC'92), pages 191-207.+--+--   * Chris Okasaki. \"Three algorithms on Braun Trees\".  +--     /Journal of Function Programming/ 7(6):661-666. Novemebr 1997.++module Data.Edison.Seq.BraunSeq (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Control.Monad+import Control.Monad.Identity+import Data.Maybe+import Data.Monoid+import Test.QuickCheck++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) )+import Data.Edison.Seq.Defaults+import qualified Data.Edison.Seq.ListSeq as L+++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.BraunSeq"+++data Seq a = E | B a (Seq a) (Seq a)    deriving (Eq)++half :: Int -> Int+half n = n `quot` 2  -- use a shift?++empty = E+singleton x = B x E E++lcons x E = singleton x+lcons x (B y a b) = B x (lcons y b) a++rcons y ys = insAt (size ys) ys+  where insAt 0 _ = singleton y+        insAt i (B x a b)+          | odd i     = B x (insAt (half i) a) b+          | otherwise = B x a (insAt (half i - 1) b)+        insAt _ _ = error "BraunSeq.rcons: bug.  Impossible case!"++append xs E = xs+append xs ys = app (size xs) xs ys+  where app 0 xs ys = ys+        app n xs E = xs+        app n (B x a b) (B y c d)+            | odd n     = B x (app m a (lcons y d)) (app m b c)+            | otherwise = B x (app m a c) (app (m-1) b (lcons y d))+          where m = half n+        app _ _ _ = error "BraunSeq.append: bug!"+  -- how does it compare to converting to/from lists?++lview E = fail "BraunSeq.lview: empty sequence"+lview (B x a b) = return (x, combine a b)++-- not exported+combine E _ = E+combine (B x a b) c = B x c (combine a b)++lhead E = error "BraunSeq.lhead: empty sequence"+lhead (B x a b) = x++lheadM E = fail "BraunSeq.lheadM: empty sequence"+lheadM (B x a b) = return x++ltail E = error "BraunSeq.ltail: empty sequence"+ltail (B x a b) = combine a b++ltailM E = fail "BraunSeq.ltailM: empty sequence"+ltailM (B x a b) = return (combine a b)++-- not exported+-- precondition: i >= 0+delAt 0 _ = E+delAt i (B x a b)+  | odd i     = B x (delAt (half i) a) b+  | otherwise = B x a (delAt (half i - 1) b)+delAt _ _ = error "BraunSeq.delAt: bug.  Impossible case!"++rview E = fail "BraunSeq.rview: empty sequence"+rview xs = return (lookup m xs, delAt m xs)+  where m = size xs - 1++rhead E = error "BraunSeq.rhead: empty sequence"+rhead xs = lookup (size xs - 1) xs++rheadM E = fail  "BraunSeq.rheadM: empty sequence"+rheadM xs = return (lookup (size xs - 1) xs)++rtail E = error "BraunSeq.rtail: empty sequence"+rtail xs = delAt (size xs - 1) xs++rtailM E = fail "BraunSeq.rtailM: empty sequence"+rtailM xs = return (delAt (size xs - 1) xs)++null E = True+null _ = False++size E = 0+size (B x a b) = 1 + n + n + diff n a+  where n = size b++        diff 0 E = 0+        diff 0 (B x a b) = 1+        diff i (B x a b)+          | odd i     = diff (half i) a+          | otherwise = diff (half i - 1) b+        diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!"++reverse xs = rev00 (size xs) xs+  where+    rev00 n xs+      | n <= 1 = xs+    rev00 n (B x a b)+      | odd n     = let a'      = rev00 m a+                        (x',b') = rev11 m x b      in B x' a' b'+      | otherwise = let (x',a') = rev01 m a+                        b'      = rev10 (m-1) x b  in B x' b' a'+      where m = half n+    rev00 _ _ = error "BraunSeq.reverse: bug!"++    rev11 n x E = (x,E)+    rev11 n x (B y a b)+      | odd n     = let (x',a') = rev11 m x a+                        (y',b') = rev11 m y b      in (y', B x' b' a')+      | otherwise = let (x',a') = rev11 m x a+                        (y',b') = rev11 (m-1) y b  in (x', B y' a' b')+      where m = half n++    rev01 n E = error "BraunSeq.reverse: bug!"+    rev01 n (B x a b)+      | n == 1    = (x, E)+      | odd n     = let (y',a') = rev01 m a+                        (x',b') = rev11 m x b      in (x', B y' b' a')+      | otherwise = let (y',a') = rev01 m a+                        (x',b') = rev11 (m-1) x b  in (y', B x' a' b')+      where m = half n++    rev10 n x E = B x E E+    rev10 n x (B y a b)+      | odd n     = let a'      = rev10 m x a+                        (y',b') = rev11 m y b      in B y' a' b'+      | otherwise = let (x',a') = rev11 m x a+                        b'      = rev10 (m-1) y b  in B x' b' a'+      where m = half n++fromList = L.lhead . L.foldr build [E] . rows 1+  where rows k [] = []+        rows k xs = (k, ys) : rows (k+k) zs+          where (ys,zs) = L.splitAt k xs++        build (k,xs) ts = zipWithB xs ts1 ts2+          where (ts1, ts2) = L.splitAt k ts++        zipWithB [] _ _ = []+        zipWithB (x:xs) [] _ = singleton x : L.map singleton xs+        zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts []+        zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2++toList E = []+toList t = tol [t]+  where tol [] = []+        tol ts = xs ++ tol (ts1 ++ ts2)+          where xs = L.map root ts+                (ts1,ts2) = children ts++                children [] = ([],[])+                children (B x E _ : ts) = ([],[])+                children (B x a E : ts) = (a : leftChildren ts, [])+                children (B x a b : ts) = (a : ts1, b : ts2)+                  where (ts1, ts2) = children ts+                children _ = error "BraunSeq.toList: bug!"++                leftChildren [] = []+                leftChildren (B x E _ : ts) = []+                leftChildren (B x a b : ts) = a : leftChildren ts+                leftChildren _ = error "BraunSeq.toList: bug!"++                root (B x a b) = x+                root _ = error "BraunSeq.toList: bug!"++                left (B x a b) = a+                left _ = error "BraunSeq.toList: bug!"++map f E = E+map f (B x a b) = B (f x) (map f a) (map f b)++copy n x = if n <= 0 then empty else fst (copy2 n)+  where copy2 n+            | odd n     = (B x a a, B x b a)+            | n == 0    = (E, singleton x)+            | otherwise = (B x b a, B x b b)+          where (a, b) = copy2 (half (n-1))++inBounds i xs = (i >= 0) && inb xs i+  where inb E i = False+        inb (B x a b) i+          | odd i     = inb a (half i)+          | i == 0    = True+          | otherwise = inb b (half i - 1)++lookup i xs = runIdentity (lookupM i xs)++lookupM i xs+  | i < 0     = fail "BraunSeq.lookupM: bad subscript"+  | otherwise = look xs i+  where look E i = nothing+        look (B x a b) i+          | odd i     = look a (half i)+          | i == 0    = return x+          | otherwise = look b (half i - 1)+        nothing = fail "BraunSeq.lookupM: not found"++lookupWithDefault d i xs = if i < 0 then d+                           else look xs i+  where look E i = d+        look (B x a b) i+          | odd i     = look a (half i)+          | i == 0    = x+          | otherwise = look b (half i - 1)++update i y xs = if i < 0 then xs else upd i xs+  where upd i E = E+        upd i (B x a b)+          | odd i     = B x (upd (half i) a) b+          | i == 0    = B y a b+          | otherwise = B x a (upd (half i - 1) b)++adjust f i xs = if i < 0 then xs else adj i xs+  where adj i E = E+        adj i (B x a b)+          | odd i     = B x (adj (half i) a) b+          | i == 0    = B (f x) a b+          | otherwise = B x a (adj (half i - 1) b)++mapWithIndex f xs = mwi 0 1 xs+  where mwi i d E = E+        mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b)+          where dd = d+d++take n xs = if n <= 0 then E else ta n xs+  where ta n E = E+        ta n (B x a b)+            | odd n     = B x (ta m a) (ta m b)+            | n == 0    = E+            | otherwise = B x (ta m a) (ta (m-1) b)+          where m = half n++drop n xs = if n <= 0 then xs else dr n xs+  where dr n E = E+        dr n t@(B x a b)+            | odd n     = combine (dr m a) (dr m b)+            | n == 0    = t+            | otherwise = combine (dr (m-1) b) (dr m a)+          where m = half n++zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d)+zip _ _ = E++zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f)+zip3 _ _ _ = E++zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d)+zipWith f _ _ = E++zipWith3 fn (B x a b) (B y c d) (B z e f) = +    B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f)+zipWith3 fn _ _ _ = E++unzip E = (E, E)+unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2)+  where (a1,a2) = unzip a+        (b1,b2) = unzip b++unzip3 E = (E, E, E)+unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3)+  where (a1,a2,a3) = unzip3 a+        (b1,b2,b3) = unzip3 b++unzipWith f g E = (E, E)+unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2)+  where (a1,a2) = unzipWith f g a+        (b1,b2) = unzipWith f g b++unzipWith3 f g h E = (E, E, E)+unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3)+  where (a1,a2,a3) = unzipWith3 f g h a+        (b1,b2,b3) = unzipWith3 f g h b+++strict s@E = s+strict s@(B x l r) = strict l `seq` strict r `seq` s++strictWith f s@E = s+strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s++-- invariants:+--   * Left subtree is exactily the same size as the right+--     subtree, or one element larger++structuralInvariant E         = True+structuralInvariant (B _ l r) = isJust (check l r)++  where check E           E           = Just 1+        check (B _ E E)   E           = Just 2+        check (B _ l1 l2) (B _ r1 r2) = do+           x <- check l1 l2+           y <- check r1 r2+           if (x == y) || (x == y + 1)+              then return (x+y+1)+              else fail "unbalanced tree"+        check _ _ = fail "unbalanced tree"+++-- the remaining functions all use defaults++concat = concatUsingFoldr+reverseOnto = reverseOntoUsingReverse+concatMap = concatMapUsingFoldr+fold = foldrUsingLists+fold' f = foldl'UsingLists (flip f)+fold1 = fold1UsingFold+fold1' = fold1'UsingFold'+foldr = foldrUsingLists+foldr' = foldr'UsingLists+foldl = foldlUsingLists+foldl' = foldl'UsingLists+foldr1 = foldr1UsingLists+foldr1' = foldr1'UsingLists+foldl1 = foldl1UsingLists+foldl1' = foldl1UsingLists+reducer = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel = reducelUsingReduce1+reducel' = reducel'UsingReduce1'+reduce1 = reduce1UsingLists+reduce1' = reduce1'UsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+splitAt = splitAtDefault+subseq = subseqDefault+filter = filterUsingLists+partition = partitionUsingLists+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview+++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; +   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++-- instance Eq (Seq a) is derived++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = arbitrary >>= (return . fromList)+  coarbitrary xs = coarbitrary (toList xs)++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/Defaults.hs view
@@ -0,0 +1,513 @@+-- |+--   Module      :  Data.Edison.Seq.Defaults+--   Copyright   :  Copyright (c) 1998 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  internal (unstable)+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module provides default implementations of many of+--   the sequence operations.  It is used to fill in implementations+--   and is not intended for end users.++module Data.Edison.Seq.Defaults where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Control.Monad.Identity+import Data.Char (isSpace)++import Data.Edison.Prelude+import Data.Edison.Seq+import qualified Data.Edison.Seq.ListSeq as L++rconsUsingAppend :: Sequence s => a -> s a -> s a+rconsUsingAppend x s = append s (singleton x)++rconsUsingFoldr :: Sequence s => a -> s a -> s a+rconsUsingFoldr x s = foldr lcons (singleton x) s++appendUsingFoldr :: Sequence s => s a -> s a -> s a+appendUsingFoldr s t | null t = s+                            | otherwise = foldr lcons t s++rviewDefault :: (Monad m, Sequence s) => s a -> m (a, s a)+rviewDefault xs+  | null xs   = fail $ instanceName xs ++ ".rview: empty sequence"+  | otherwise = return (rhead xs, rtail xs)+++rtailUsingLview :: (Sequence s) => s a -> s a+rtailUsingLview xs = +    case lview xs of+      Nothing      -> error $ instanceName xs ++ ".rtail: empty sequence"+      Just (x, xs) -> rt x xs+  where rt x xs =+          case lview xs of+            Nothing      -> empty+            Just (y, ys) -> lcons x (rt y ys)++rtailMUsingLview :: (Monad m,Sequence s) => s a -> m (s a)+rtailMUsingLview xs = +    case lview xs of+      Nothing      -> fail $ instanceName xs ++ ".rtailM: empty sequence"+      Just (x, xs) -> return (rt x xs)+  where rt x xs =+          case lview xs of+            Nothing      -> empty+            Just (y, ys) -> lcons x (rt y ys)++++concatUsingFoldr :: Sequence s => s (s a) -> s a+concatUsingFoldr = foldr append empty++reverseUsingReverseOnto :: Sequence s => s a -> s a+reverseUsingReverseOnto s = reverseOnto s empty++reverseUsingLists :: Sequence s => s a -> s a+reverseUsingLists = fromList . L.reverse . toList++reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a+reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs++reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a+reverseOntoUsingReverse = append . reverse++fromListUsingCons :: Sequence s => [a] -> s a+fromListUsingCons = L.foldr lcons empty++toListUsingFoldr :: Sequence s => s a -> [a]+toListUsingFoldr = foldr (:) []++mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b+mapUsingFoldr f = foldr (lcons . f) empty++concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b+concatMapUsingFoldr f = foldr (append . f) empty++foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b+foldrUsingLists f e xs = L.foldr f e (toList xs)++foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b+foldr'UsingLists f e xs = L.foldr' f e (toList xs)++foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b+foldlUsingLists f e xs = L.foldl f e (toList xs)++foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b+foldl'UsingLists f e xs = L.foldl' f e (toList xs)++foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+foldr1UsingLists f xs = L.foldr1 f (toList xs)++foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+foldr1'UsingLists f xs = L.foldr1' f (toList xs)++foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+foldl1UsingLists f xs = L.foldl1 f (toList xs)++foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+foldl1'UsingLists f xs = L.foldl1' f (toList xs)++fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a+fold1UsingFold f xs =+    case lview xs of+      Nothing      -> error $ instanceName xs ++ ".fold1: empty sequence"+      Just (x, xs) -> fold f x xs++fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a+fold1'UsingFold' f xs =+    case lview xs of+      Nothing      -> error $ instanceName xs ++ ".fold1': empty sequence"+      Just (x, xs) -> fold' f x xs++foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a+foldr1UsingLview f xs = +    case lview xs of+      Nothing      -> error $ instanceName xs ++ ".foldr1: empty sequence"+      Just (x, xs) -> fr1 x xs+  where fr1 x xs =+          case lview xs of+            Nothing     -> x+            Just (y,ys) -> f x (fr1 y ys)++foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a+foldr1'UsingLview f xs =+     case lview xs of+        Nothing     -> error $ instanceName xs ++ ".foldr1': empty sequence"+        Just (x,xs) -> fr1 x xs+  where fr1 x xs = +          case lview xs of+             Nothing     -> x+             Just (y,ys) -> f x $! (fr1 y ys)++foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a+foldl1UsingFoldl f xs = +    case lview xs of+      Nothing     -> error $ instanceName xs ++ ".foldl1: empty sequence"+      Just (x,xs) -> foldl f x xs++foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a+foldl1'UsingFoldl' f xs =+    case lview xs of+      Nothing     -> error $ instanceName xs ++ ".foldl1': empty sequence"+      Just (x,xs) -> foldl' f x xs++reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a+reducerUsingReduce1 f e s+  | null s = e+  | otherwise = f (reduce1 f s) e++reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a+reducer'UsingReduce1' f e s+  | null s = e+  | otherwise = f (reduce1' f s) e++reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a+reducelUsingReduce1 f e s+  | null s = e+  | otherwise = f e (reduce1 f s)++reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a+reducel'UsingReduce1' f e s+  | null s = e+  | otherwise = f e (reduce1' f s)++reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+reduce1UsingLists f s = L.reduce1 f (toList s)++reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a+reduce1'UsingLists f s = L.reduce1' f (toList s)++copyUsingLists :: Sequence s => Int -> a -> s a+copyUsingLists n x = fromList (L.copy n x)+++inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool+inBoundsUsingDrop i s = +  i >= 0 && not (null (drop i s))++inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool+inBoundsUsingLookupM i s =+  case lookupM i s of+    Just x  -> True+    Nothing -> False++inBoundsUsingSize :: Sequence s => Int -> s a -> Bool+inBoundsUsingSize i s = i >= 0 && i < size s++lookupUsingLookupM :: Sequence s => Int -> s a -> a+lookupUsingLookupM i s = runIdentity (lookupM i s)++lookupUsingDrop :: Sequence s => Int -> s a -> a+lookupUsingDrop i s+  | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript"+  | otherwise = lhead s'+  where s' = drop i s++lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a+lookupWithDefaultUsingLookupM d i s =+  case lookupM i s of+    Nothing -> d+    Just x  -> x++lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a+lookupWithDefaultUsingDrop d i s+  | i < 0 || null s' = d+  | otherwise = lhead s'+  where s' = drop i s++lookupMUsingDrop :: (Monad m, Sequence s) => Int -> s a -> m a+lookupMUsingDrop i s+  -- XXX better error message!+  | i < 0 || null s' = fail $ instanceName s+  			++ ".lookupMUsingDrop: empty sequence"+  | otherwise        = return (lhead s')+  where s' = drop i s++filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a+filterUsingLview p xs =+  case lview xs of+    Nothing     -> empty+    Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs++filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a+filterUsingLists p xs =+  fromList (L.filter p (toList xs))++filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a+filterUsingFoldr p = foldr pcons empty+  where pcons x xs = if p x then lcons x xs else xs++partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a)+partitionUsingLists p xs =+  let (ys,zs) = L.partition p (toList xs)+  in (fromList ys, fromList zs)++partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a)+partitionUsingFoldr p = foldr pcons (empty, empty)+  where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs')++updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a+updateUsingAdjust i y = adjust (const y) i++updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a+updateUsingSplitAt i x xs+  | i < 0 = xs+  | otherwise = let (ys,zs) = splitAt i xs+                in if null zs then xs else append ys (lcons x (ltail zs))++adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a+adjustUsingLists f i xs = fromList (L.adjust f i (toList xs))++adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a+adjustUsingSplitAt f i xs+  | i < 0 = xs+  | otherwise = let (ys,zs) = splitAt i xs+                in case lview zs of+                     Nothing      -> xs+                     Just (z,zs') -> append ys (lcons (f z) zs')++{-+insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a+insertAtUsingLists i x xs = +  fromList (L.insertAt i x (toList xs))++insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a+insertAtUsingSplitAt i x xs+  | (xs_before, xs_after) <- splitAt i xs =+      append xs_before (lcons x xs_after)++deleteAtUsingLists :: Sequence s => Int -> s a -> s a+deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs))++deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a+deleteAtUsingSplitAt i xs+  | (xs_before, xs_after) <- splitAt i xs =+      append xs_before (ltail xs_after)+-}++mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b+mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs))++foldrWithIndexUsingLists :: +  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b+foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs)++foldrWithIndex'UsingLists :: +  Sequence s => (Int -> a -> b -> b) -> b -> s a -> b+foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs)++foldlWithIndexUsingLists :: +  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b+foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs)++foldlWithIndex'UsingLists :: +  Sequence s => (b -> Int -> a -> b) -> b -> s a -> b+foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs)++takeUsingLists :: Sequence s => Int -> s a -> s a+takeUsingLists i s = fromList (L.take i (toList s))++takeUsingLview :: Sequence s => Int -> s a -> s a+takeUsingLview i xs+  | i <= 0 = empty+  | otherwise = case lview xs of+                  Nothing -> empty+                  Just (x,xs') -> lcons x (take (i-1) xs')++dropUsingLists :: Sequence s => Int -> s a -> s a+dropUsingLists i s = fromList (L.drop i (toList s))++dropUsingLtail :: Sequence s => Int -> s a -> s a+dropUsingLtail i xs+  | i <= 0 || null xs = xs+  | otherwise = dropUsingLtail (i-1) (ltail xs)++splitAtDefault :: Sequence s => Int -> s a -> (s a, s a)+splitAtDefault i s = (take i s, drop i s)++splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a)+splitAtUsingLview i xs+  | i <= 0 = (empty,xs)+  | otherwise = case lview xs of+                  Nothing      -> (empty,empty)+                  Just (x,xs') -> (lcons x ys,zs)+                    where (ys,zs) = splitAtUsingLview (i-1) xs'++subseqDefault :: Sequence s => Int -> Int -> s a -> s a+subseqDefault i len xs = take len (drop i xs)++takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a+takeWhileUsingLview p xs =+  case lview xs of+    Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs')+    _                  -> empty++dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a+dropWhileUsingLview p xs =+  case lview xs of+    Just (x,xs') | p x -> dropWhileUsingLview p xs'+    _                  -> xs++splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a)+splitWhileUsingLview p xs =+  case lview xs of+    Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs'+                          in (lcons x front, back)+    _                  -> (empty, xs)++zipUsingLview :: Sequence s => s a -> s b -> s (a,b)+zipUsingLview xs ys =+  case lview xs of+    Nothing -> empty+    Just (x,xs') ->+      case lview ys of+        Nothing -> empty+        Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys')++zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c)+zip3UsingLview xs ys zs =+  case lview xs of+    Nothing -> empty+    Just (x,xs') ->+      case lview ys of+        Nothing -> empty+        Just (y,ys') ->+          case lview zs of+            Nothing -> empty+            Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs')++zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c+zipWithUsingLview f xs ys =+  case lview xs of+    Nothing -> empty+    Just (x,xs') ->+      case lview ys of+        Nothing -> empty+        Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys')++zipWith3UsingLview :: +  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d+zipWith3UsingLview f xs ys zs =+  case lview xs of+    Nothing -> empty+    Just (x,xs') ->+      case lview ys of+        Nothing -> empty+        Just (y,ys') ->+          case lview zs of+            Nothing -> empty+            Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs')++zipUsingLists :: Sequence s => s a -> s b -> s (a,b)+zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys))++zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c)+zip3UsingLists xs ys zs = +  fromList (L.zip3 (toList xs) (toList ys) (toList zs))++zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c+zipWithUsingLists f xs ys =+  fromList (L.zipWith f (toList xs) (toList ys))++zipWith3UsingLists :: +  Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d+zipWith3UsingLists f xs ys zs =+  fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs))++unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b)+unzipUsingLists xys =+  case L.unzip (toList xys) of+    (xs, ys) -> (fromList xs, fromList ys)++unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b)+unzipUsingFoldr = foldr pcons (empty,empty) +  where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys)++unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c)+unzip3UsingLists xyzs =+  case L.unzip3 (toList xyzs) of+    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)++unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c)+unzip3UsingFoldr = foldr tcons (empty,empty,empty)+  where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs)++unzipWithUsingLists :: +  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)+unzipWithUsingLists f g xys =+  case L.unzipWith f g (toList xys) of+    (xs, ys) -> (fromList xs, fromList ys)++unzipWithUsingFoldr :: +  Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)+unzipWithUsingFoldr f g = foldr pcons (empty,empty) +  where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys)++unzipWith3UsingLists :: +  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)+unzipWith3UsingLists f g h xyzs =+  case L.unzipWith3 f g h (toList xyzs) of+    (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)++unzipWith3UsingFoldr :: +  Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)+unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty) +  where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs)++showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS+showsPrecUsingToList i xs rest+   | i == 0    = concat [    instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest+   | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest)++readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a)+readsPrecUsingFromList i xs =+   let result = maybeParens p xs+       p xs = tokenMatch ((instanceName x)++".fromList") xs+                >>= readsPrec 10+                >>= \(l,rest) -> return (fromList l,rest)++       -- play games with the typechecker so we don't have to use+       -- extensions for scoped type variables+       ~[(x,_)] = result++   in result++defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering+defaultCompare a b =+   case (lview a, lview b) of+     (Nothing, Nothing) -> EQ+     (Nothing, _      ) -> LT+     (_      , Nothing) -> GT+     (Just (x,xs), Just (y,ys)) ->+	case compare x y of+           EQ -> defaultCompare xs ys+           c -> c+++dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a]+dropMatch [] ys = return ys+dropMatch (x:xs) (y:ys)+    | x == y    = dropMatch xs ys+    | otherwise = mzero+dropMatch _ _   = mzero++tokenMatch :: MonadPlus m => String -> String -> m String+tokenMatch token str = dropMatch token (munch str) >>= return . munch+   where munch = dropWhile isSpace++readSParens :: ReadS a -> ReadS a+readSParens p xs = return xs+     >>= tokenMatch "("+     >>= p+     >>= \(x,xs') -> return xs'+     >>= tokenMatch ")"+     >>= \rest -> return (x,rest)++maybeParens :: ReadS a -> ReadS a+maybeParens p xs = readSParens p xs `mplus` p xs
+ src/Data/Edison/Seq/FingerSeq.hs view
@@ -0,0 +1,375 @@+-- |+--   Module      :  Data.Edison.Seq.FingerSeq+--   Copyright   :  Copyright (c) 2006 Robert Dockins+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+++module Data.Edison.Seq.FingerSeq (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldlWithIndex,+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import qualified Prelude+import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S+import Data.Edison.Seq.Defaults+import Control.Monad+import Control.Monad.Identity+import Data.Monoid+import Test.QuickCheck++#ifdef __GLASGOW_HASKELL__+import GHC.Base (unsafeCoerce#)+#endif+++import qualified Data.Edison.Concrete.FingerTree as FT++moduleName     :: String+moduleName = "Data.Edison.Seq.FingerSeq"+++newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show)+unSizeM (SizeM x) = x++instance Monoid SizeM where+   mempty  = 0+   mappend = (+)+++newtype Elem a = Elem a+unElem (Elem x) = x++instance Measured SizeM (Elem a) where+   measure _ = 1++newtype Seq a = Seq (FT.FingerTree SizeM (Elem a))+unSeq (Seq ft) = ft++++empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++#ifdef __GLASGOW_HASKELL__++mapElem   = unsafeCoerce#+mapUnElem = unsafeCoerce#++#else++mapElem   = Prelude.map Elem+mapUnElem = Prelude.map unElem++#endif++null         = FT.null . unSeq+empty        = Seq FT.empty+singleton    = Seq . FT.singleton . Elem+lcons x      = Seq . FT.lcons (Elem x) . unSeq+rcons x      = Seq . FT.rcons (Elem x) . unSeq+append p q   = Seq $ FT.append (unSeq p) (unSeq q)+fromList     = Seq . FT.fromList . mapElem+toList       = mapUnElem . FT.toList . unSeq+reverse      = Seq . FT.reverse . unSeq+size         = unSizeM . measure . unSeq+strict       = Seq . FT.strict . unSeq+strictWith f = Seq . FT.strictWith (f . unElem) . unSeq+structuralInvariant = FT.structuralInvariant . unSeq++#ifdef __GLASGOW_HASKELL__++lview (Seq xs) =+  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)+  in  f (FT.lview xs)++rview (Seq xs) =+  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)+  in  f (FT.rview xs)++#else++lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs)+rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs)++#endif+++lheadM xs = lview xs >>= return . fst+ltailM xs = lview xs >>= return . snd+rheadM xs = rview xs >>= return . fst+rtailM xs = rview xs >>= return . snd+lhead = runIdentity . lheadM+ltail = runIdentity . ltailM+rhead = runIdentity . rheadM+rtail = runIdentity . rtailM++fold     = foldr+fold'    = foldr'+fold1    = foldr1+fold1'   = foldr1'++#ifdef __GLASGOW_HASKELL__++foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)+foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)++reduce1  f (Seq xs) = unElem $ FT.reduce1  (unsafeCoerce# f) xs+reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs++map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs++#else++foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)+foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)++reduce1  f (Seq xs) = unElem $ FT.reduce1  ( \(Elem x) (Elem y) -> Elem $ f x y) xs+reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs++map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs++#endif++lookupM i (Seq xs)+    | inBounds i (Seq xs) =+	case FT.splitTree (> (SizeM i)) (SizeM 0) xs of+           FT.Split _ (Elem x) _ -> return x++    | otherwise = fail "FingerSeq.lookupM: index out of bounds"++lookupWithDefault d i (Seq xs)+    | inBounds i (Seq xs) =+	case FT.splitTree (> (SizeM i)) (SizeM 0) xs of+           FT.Split _ (Elem x) _ -> x++    | otherwise = d++update i x (Seq xs)+    | inBounds i (Seq xs) =+	case FT.splitTree (> (SizeM i)) (SizeM 0) xs of+           FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r++    | otherwise = Seq xs++adjust f i (Seq xs)+    | inBounds i (Seq xs) =+	case FT.splitTree (> (SizeM i)) (SizeM 0) xs of+           FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r++    | otherwise = Seq xs++take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs+drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs+splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b)+++inBounds = inBoundsUsingSize+lookup   = lookupUsingLookupM++foldr1 f xs =+   case rview xs of+      Nothing      -> error "FingerSeq.foldr1: empty sequence"+      Just (x,xs') -> foldr f x xs'++foldr1' f xs =+   case rview xs of+      Nothing      -> error "FingerSeq.foldr1': empty sequence"+      Just (x,xs') -> foldr' f x xs'++foldl    = foldlUsingLists+foldl'   = foldl'UsingLists+foldl1   = foldl1UsingLists+foldl1'  = foldl1'UsingLists++reducer  = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel  = reducelUsingReduce1+reducel' = reducel'UsingReduce1'++copy        = copyUsingLists+concat      = concatUsingFoldr+reverseOnto = reverseOntoUsingReverse+concatMap   = concatMapUsingFoldr+subseq      = subseqDefault+filter      = filterUsingLview+partition   = partitionUsingFoldr+takeWhile   = takeWhileUsingLview+dropWhile   = dropWhileUsingLview+splitWhile  = splitWhileUsingLview++mapWithIndex    = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists++zip = zipUsingLview+zip3 = zip3UsingLview+zipWith = zipWithUsingLview+zipWith3 = zipWith3UsingLview++unzip = unzipUsingFoldr+unzip3 = unzip3UsingFoldr+unzipWith = unzipWithUsingFoldr+unzipWith3 = unzipWith3UsingFoldr++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Eq a => Eq (Seq a) where+  xs == ys = toList xs == toList ys++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Elem a) where+   arbitrary   = arbitrary >>= return . Elem+   coarbitrary = coarbitrary . unElem++instance Arbitrary a => Arbitrary (Seq a) where+   arbitrary   = arbitrary >>= return . Seq+   coarbitrary = coarbitrary . unSeq++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/JoinList.hs view
@@ -0,0 +1,427 @@+-- |+--   Module      :  Data.Edison.Seq.JoinList+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Join lists. All running times are as listed in "Data.Edison.Seq" except+--   for the following:+--+--   * rcons, append         @O( 1 )@+--+--   * ltail*, lview         @O( 1 )@    when used single-threaded, @O( n )@ otherwise+--+--   * lhead*                @O( n )@+--+--   * inBounds, lookup      @O( n )@+--+--   * copy                  @O( log i )@+--+--   * concat                @O( n1 )@+--+--   * concatMap, (>>=)      @O( n * t )@, where @n@ is the length of the input sequence and+--                                         @t@ is the running time of @f@++module Data.Edison.Seq.JoinList (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldlWithIndex,+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) )+import Data.Edison.Seq.Defaults+import Control.Monad+import Data.Monoid+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.JoinList"++data Seq a = E | L a | A (Seq a) (Seq a)+  -- invariant: E never a child of A++half :: Int -> Int+half n = n `div` 2++empty = E+singleton = L++lcons x E = L x+lcons x xs = A (L x) xs++rcons x E = L x+rcons x xs = A xs (L x)++append E ys = ys+append xs E = xs+append xs ys = A xs ys+++-- path reversal on lview/ltail++lview E = fail "JoinList.lview: empty sequence"+lview (L x) = return (x, E)+lview (A xs ys) = lvw xs ys+  where lvw E zs = error "JoinList.lvw: bug"+        lvw (L x) zs = return (x, zs)+        lvw (A xs ys) zs = lvw xs (A ys zs)++lhead E = error "JoinList.lhead: empty sequence"+lhead (L x) = x+lhead (A xs ys) = lhead xs++lheadM E = fail "JoinList.lheadM: empty sequence"+lheadM (L x) = return x+lheadM (A xs ys) = lheadM xs++ltail E = error "JoinList.ltail: empty sequence"+ltail (L x) = E+ltail (A xs ys) = ltl xs ys+  where ltl E zs = error "JoinList.ltl: bug"+        ltl (L x) zs = zs+        ltl (A xs ys) zs = ltl xs (A ys zs)++ltailM E = fail "JoinList.ltailM: empty sequence"+ltailM (L x) = return E+ltailM (A xs ys) = return (ltl xs ys)+  where ltl E zs = error "JoinList.ltl: bug"+        ltl (L x) zs = zs+        ltl (A xs ys) zs = ltl xs (A ys zs)+++-- Don't want to do plain path reversal on rview/rtail because of expectation+-- that left accesses are more common, so we would prefer to keep the left+-- spine short.++rview E = fail "JoinLis.rview: empty sequence"+rview (L x) = return (x, E)+rview (A xs ys) = rvw xs ys+  where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s+        rvw xs (A ys (L x)) = return (x, A xs ys)+        rvw xs (L x) = return (x, xs)+        rvw xs _ = error "JoinList.rvw: bug"+ +rhead E = error "JoinList.rhead: empty sequence"+rhead (L x) = x+rhead (A xs ys) = rhead ys++rheadM E = fail "JoinList.rheadM: empty sequence"+rheadM (L x) = return x+rheadM (A xs ys) = rheadM ys++rtail E = error "JoinList.rtail: empty sequence"+rtail (L x) = E+rtail (A xs ys) = rtl xs ys+  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)+        rtl xs (A ys (L _)) = A xs ys+        rtl xs (L x) = xs+        rtl xs _ = error "JoinList.rtl: bug"++rtailM E = fail "JoinList.rtailM: empty sequence"+rtailM (L x) = return E+rtailM (A xs ys) = return (rtl xs ys)+  where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)+        rtl xs (A ys (L _)) = A xs ys+        rtl xs (L x) = xs+        rtl xs _ = error "JoinList.rtl: bug"++null E = True+null _ = False++size xs = sz xs (0::Int)+  where sz E n = n+        sz (L x) n = n + (1::Int)+        sz (A xs ys) n = sz xs (sz ys n)++reverse (A xs ys) = A (reverse ys) (reverse xs)+reverse xs = xs -- L x or E++toList xs = tol xs []+  where tol E rest = rest+        tol (L x) rest = x:rest+        tol (A xs ys) rest = tol xs (tol ys rest)++map f E = E+map f (L x) = L (f x)+map f (A xs ys) = A (map f xs) (map f ys)++fold   = foldr+fold'  = foldr'+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr f e E = e+foldr f e (L x) = f x e+foldr f e (A xs ys) = foldr f (foldr f e ys) xs++foldr' f e E = e+foldr' f e (L x) = f x $! e+foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs++foldl f e E = e+foldl f e (L x) = f e x+foldl f e (A xs ys) = foldl f (foldl f e xs) ys++foldl' f e E = e+foldl' f e (L x) = e `seq` f e x+foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys++foldr1 f E = error "JoinList.foldr1: empty sequence"+foldr1 f (L x) = x+foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs++foldr1' f E = error "JoinLis.foldr1': empty sequence"+foldr1' f (L x) = x+foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs++foldl1 f E = error "JoinList.foldl1: empty sequence"+foldl1 f (L x) = x+foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys++foldl1' f E = error "JoinList.foldl1': empty sequence"+foldl1' f (L x) = x+foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys++copy n x +    | n <= 0 = E+    | otherwise = cpy n x+  where cpy n x  -- n > 0+          | even n = let xs = cpy (half n) x+                     in A xs xs+          | n == 1 = L x+          | otherwise = let xs = cpy (half n) x+                        in A (L x) (A xs xs)+++strict s@E = s+strict s@(L x) = s+strict s@(A l r) = strict l `seq` strict r `seq` s++strictWith f s@E = s+strictWith f s@(L x) = f x `seq` s+strictWith f s@(A l r) = strictWith f l `seq` strictWith f l `seq` s++-- invariants:+--   * 'E' is never a child of 'A'++structuralInvariant E = True+structuralInvariant s = check s+  where check E = False+        check (L _) = True+        check (A s1 s2) = check s1 && check s2+++concat = concatUsingFoldr+reverseOnto = reverseOntoUsingReverse+fromList = fromListUsingCons+concatMap = concatMapUsingFoldr++reducer  = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel  = reducelUsingReduce1+reducel' = reducel'UsingReduce1'+reduce1  = reduce1UsingLists+reduce1' = reduce1'UsingLists++inBounds = inBoundsUsingDrop+lookup = lookupUsingDrop+lookupM = lookupMUsingDrop+lookupWithDefault = lookupWithDefaultUsingDrop++update = updateUsingSplitAt+adjust = adjustUsingSplitAt++mapWithIndex = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists++take = takeUsingLview+drop = dropUsingLtail+splitAt = splitAtUsingLview+subseq = subseqDefault+        +filter = filterUsingLview+partition = partitionUsingFoldr+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview++zip = zipUsingLview+zip3 = zip3UsingLview+zipWith = zipWithUsingLview+zipWith3 = zipWith3UsingLview++unzip = unzipUsingFoldr+unzip3 = unzip3UsingFoldr+unzipWith = unzipWithUsingFoldr+unzipWith3 = unzipWith3UsingFoldr++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;+   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Eq a => Eq (Seq a) where+  xs == ys = toList xs == toList ys++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = sized arbTree+    where arbTree 0 = return E+          arbTree 1 = liftM L arbitrary+          arbTree n =+            frequency [(1, liftM L arbitrary),+                       (4, liftM2 A (arbTree (n `div` 2))+                                    (arbTree (n `div` 2)))]++  coarbitrary E = variant 0+  coarbitrary (L x) = variant 1 . coarbitrary x+  coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/MyersStack.hs view
@@ -0,0 +1,438 @@+-- |+--   Module      :  Data.Edison.Seq.MyersStack+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Meyers Stacks.  All operations are as listed in "Data.Edison.Seq" except+--   the following:+--+-- * lookup, inBounds, drop  @O( min(i, log n) )@+--+-- * rhead*, size  @O( log n )@+--+-- * subseq        @O( min (i, log n) + len )@+--+--   /References:/+--+-- * Eugene Myers. \"An applicative random-access stack\". /Information+--   Processing Letters/, 17(5):241-248, December 1983.++module Data.Edison.Seq.MyersStack (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) )+import Data.Edison.Seq.Defaults+import Control.Monad+import Control.Monad.Identity+import Data.Monoid+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.MyersStack"+++data Seq a = E | C !Int a (Seq a) (Seq a)+  -- what about strictness flags on tail and jump-tail?++-- auxiliary function+jump (C _ _ _ (C _ _ _ xs')) = xs'+jump _ = error "MyersStack.jump: bug!"++empty = E+singleton x = C 1 x E E++lcons x xs@(C i _  _  (C j _ _ xs'))+    | i == j = C (1 + i + j) x xs xs'+lcons x xs = C 1 x xs xs++lview E = fail "MyersStack.lview: empty sequence"+lview (C _ x xs _) = return (x, xs)++lhead E = error "MyersStack.lhead: empty sequence"+lhead (C _ x xs _) = x++lheadM E = fail "MyersStack.lheadM: empty sequence"+lheadM (C _ x xs _) = return x++ltail E = error "MyersStack.ltail: empty sequence"+ltail (C _ x xs _) = xs++ltailM E = fail "MyersStack.ltailM: empty sequence"+ltailM (C _ x xs _) = return xs++rview E = fail "MyersStack.rview: empty sequence"+rview xs = return (rhead xs, rtail xs)++rhead E = error "MyersStack.rhead: empty sequence"+rhead (C _ x xs xs') = rh x xs xs'+  where rh x xs (C _ y ys ys') = rh y ys ys'+        rh x (C _ y ys ys') E = rh y ys ys'+        rh x E E = x++rheadM E = fail "MyersStack.rheadM: empty sequence"+rheadM (C _ x xs xs') = return (rh x xs xs')+  where rh x xs (C _ y ys ys') = rh y ys ys'+        rh x (C _ y ys ys') E = rh y ys ys'+        rh x E E = x++rtail E = error "MyersStack.rtail: empty sequence"+rtail (C _ x xs _) = rt x xs+  where rt y E = E+        rt y (C _ x xs _) = lcons y (rt x xs)++rtailM E = fail "MyersStack.rtailM: empty sequence"+rtailM (C _ x xs _) = return (rt x xs)+  where rt y E = E+        rt y (C _ x xs _) = lcons y (rt x xs)++null E = True+null _ = False++size xs = go xs+  where go E = (0::Int)+        go (C j x xs xs') = j + size xs'++reverseOnto E ys = ys+reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys)++map f E = E+map f (C j x xs xs')+    | j == 1    = C j (f x) ys ys+    | otherwise = C j (f x) ys (jump ys)+  where ys = map f xs++fold  = foldr+fold' f = foldl' (flip f)+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr f e E = e+foldr f e (C _ x xs _) = f x (foldr f e xs)++foldr' f e E = e+foldr' f e (C _ x xs _) = f x $! (foldr' f e xs)++foldl f e E = e+foldl f e (C _ x xs _) = foldl f (f e x) xs++foldl' f e E = e+foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs++foldr1 f E = error "MyersStack.foldr1: empty sequence"+foldr1 f (C _ x xs _) = fr x xs+  where fr y E = y+        fr y (C _ x xs _) = f y (fr x xs)++foldr1' f E = error "MyersStack.foldr1': empty sequence"+foldr1' f (C _ x xs _) = fr x xs+  where fr y E = y+        fr y (C _ x xs _) = f y $! (fr x xs)++foldl1 f E = error "MyersStack.foldl1: empty sequence"+foldl1 f (C _ x xs _) = foldl f x xs++foldl1' f E = error "MyersStack.foldl1': empty sequence"+foldl1' f (C _ x xs _ ) = foldl' f x xs++inBounds i xs = inb xs i+  where inb E i = False+        inb (C j x xs xs') i+          | i < j     = (i >= 0)+          | otherwise = inb xs' (i - j)++lookup i xs = runIdentity (lookupM i xs)++lookupM i xs = look xs i+  where look E i = fail "MyersStack.lookup: bad subscript"+        look (C j x xs xs') i+          | i >= j   = look xs' (i - j)+          | i > 0    = look xs  (i - 1)+          | i == 0   = return x+          | otherwise = nothing+	nothing = fail "MyersStack.lookup: not found"++lookupWithDefault d i xs = look xs i+  where look E i = d+        look (C j x xs xs') i+          | i >= j   = look xs' (i - j)+          | i > 0    = look xs  (i - 1)+          | i == 0   = x+          | otherwise = d++update i y xs = upd i xs+  where upd i E = E+        upd 0 (C j x xs xs') = C j y xs xs'+        upd i (C j x xs _)+            | j == 1    = C j x ys ys+            | otherwise = C j x ys (jump ys)+          where ys = upd (i - 1) xs++adjust f i xs = adj i xs+  where adj i E = E+        adj 0 (C j x xs xs') = C j (f x) xs xs'+        adj i (C j x xs _)+            | j == 1    = C j x ys ys+            | otherwise = C j x ys (jump ys)+          where ys = adj (i - (1::Int)) xs++drop n xs = drp n xs+  where drp n xs | n <= 0 = xs+        drp n E = E+        drp n (C j x xs xs')+          | n < j     = drp (n - 1) xs+          | otherwise = drp (n - j) xs'++unzip E = (E, E)+unzip (C j (x,y) ps ps')+    | j == 1    = (C j x xs xs, C j y ys ys)+    | otherwise = (C j x xs (jump xs), C j y ys (jump ys))+  where (xs,ys) = unzip ps++unzip3 E = (E, E, E)+unzip3 (C j (x,y,z) ts ts')+    | j == 1    = (C j x xs xs, C j y ys ys, C j z zs zs)+    | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs))+  where (xs,ys,zs) = unzip3 ts++unzipWith f g E = (E, E)+unzipWith f g (C j x xs _)+    | j == 1    = (C j (f x) as as, C j (g x) bs bs)+    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs))+  where (as,bs) = unzipWith f g xs++unzipWith3 f g h E = (E, E, E)+unzipWith3 f g h (C j x xs _)+    | j == 1    = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs)+    | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs),+                   C j (h x) cs (jump cs))+  where (as,bs,cs) = unzipWith3 f g h xs++strict s@E = s+strict s@(C i x xs _) = strict xs `seq` s++strictWith f s@E = s+strictWith f s@(C i x xs _) = f x `seq` strictWith f xs `seq` s++-- the remaining functions all use defaults++rcons = rconsUsingFoldr+append = appendUsingFoldr+concat = concatUsingFoldr+reverse = reverseUsingReverseOnto+fromList = fromListUsingCons+toList = toListUsingFoldr+concatMap = concatMapUsingFoldr+reducer  = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel  = reducelUsingReduce1+reducel' = reducel'UsingReduce1'+reduce1  = reduce1UsingLists+reduce1' = reduce1'UsingLists+copy = copyUsingLists+mapWithIndex = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+take = takeUsingLists+splitAt = splitAtDefault+filter = filterUsingFoldr+partition = partitionUsingFoldr+subseq = subseqDefault+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview++-- for zips, could optimize by calculating which one is shorter and+-- retaining its shape++zip = zipUsingLists+zip3 = zip3UsingLists+zipWith = zipWithUsingLists+zipWith3 = zipWith3UsingLists++-- FIXME what are the structural invariants?+structuralInvariant = const True++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel';  reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Eq a => Eq (Seq a) where+  xs == ys =+    (size xs == size ys) && (toList xs == toList ys)++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList+++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = do xs <- arbitrary+                 return (fromList xs)++  coarbitrary xs = coarbitrary (toList xs)++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append+++-------------++{-+questions:+  - any benefit to+      E | C1 x xs | CJ Int# x xs xs'++  - any benefit to length instead of delta?++  - any benefit to delta not counting x (i.e., base 0 instead of base 1)?++I don't believe any will do any better, except possibly the first+-}+
+ src/Data/Edison/Seq/RandList.hs view
@@ -0,0 +1,481 @@+-- |+--   Module      :  Data.Edison.Seq.RandList+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Random-Access Lists.  All operations are as listed in "Data.Edison.Seq"+--   except the following:+--+--   * rhead*, size  @O( log n )@+--+--   * copy, inBounds    @O( log i )@+--+--   * lookup*, update, adjust, drop @O( min( i, log n ) )@+--+--   * subseq            @O( min( i, log n ) + len )@+--+--   /References:/+--+--   * Chris Okasaki. /Purely Functional Data Structures/. 1998.+--     Section 9.3.1.+--+--   * Chris Okasaki. \"Purely Functional Random Access Lists\".  FPCA'95,+--     pages 86-95.++module Data.Edison.Seq.RandList (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S( Sequence(..) )+import Data.Edison.Seq.Defaults+import Control.Monad+import Control.Monad.Identity+import Data.Monoid+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+moduleName = "Data.Edison.Seq.RandList"+++data Tree a = L a | T a (Tree a) (Tree a)   deriving (Eq)+data Seq a = E | C !Int (Tree a) (Seq a)    deriving (Eq)++half :: Int -> Int+half n = n `quot` 2  -- use a shift?++empty = E+singleton x = C 1 (L x) E++lcons x xs@(C i s (C j t xs'))+    | i == j = C (1 + i + j) (T x s t) xs'+lcons x xs = C 1 (L x) xs++copy n x = if n <= 0 then E else buildTrees (1::Int) (L x)+  where buildTrees j t+          | j > n     = takeTrees n (half j) (child t) E+          | otherwise = buildTrees (1 + j + j) (T x t t)++        takeTrees i j t xs+          | i >= j = takeTrees (i - j) j t (C j t xs)+          | i > 0  = takeTrees i (half j) (child t) xs+          | otherwise = xs++        child (T x s t) = t+        child _ = error "RandList.copy: bug!"++lview E = fail "RandList.lview: empty sequence"+lview (C _ (L x) xs) = return (x, xs)+lview (C i (T x s t) xs) = return (x, C j s (C j t xs))+  where j = half i++lhead E = error "RandList.lhead: empty sequence"+lhead (C _ (L x) xs) = x+lhead (C _ (T x s t) xs) = x++lheadM E = fail "RandList.lheadM: empty sequence"+lheadM (C _ (L x) xs) = return x+lheadM (C _ (T x s t) xs) = return x++ltail E = error "RandList.ltail: empty sequence"+ltail (C _ (L x) xs) = xs+ltail (C i (T x s t) xs) = C j s (C j t xs)+  where j = half i++ltailM E = fail "RandList.ltailM: empty sequence"+ltailM (C _ (L x) xs) = return xs+ltailM (C i (T x s t) xs) = return (C j s (C j t xs))+  where j = half i++rhead E = error "RandList.rhead: empty sequence"+rhead (C _ t E) = treeLast t+  where treeLast (L x) = x+        treeLast (T x s t) = treeLast t+rhead (C _ t xs) = rhead xs++rheadM E = fail "RandList.rhead: empty sequence"+rheadM (C _ t E) = return(treeLast t)+  where treeLast (L x) = x+        treeLast (T x s t) = treeLast t+rheadM (C _ t xs) = rheadM xs+++null E = True+null _ = False++size xs = sz xs+  where sz E = (0::Int)+        sz (C j t xs) = j + sz xs++reverseOnto E ys = ys+reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys)+  where revTree (L x) ys = lcons x ys+        revTree (T x s t) ys = revTree t (revTree s (lcons x ys))++map f E = E+map f (C j t xs) = C j (mapTree f t) (map f xs)+  where mapTree f (L x) = L (f x)+        mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t)++fold  = foldr+fold' f = foldl' (flip f)+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr f e E = e+foldr f e (C _ t xs) = foldTree t (foldr f e xs)+  where foldTree (L x) e = f x e+        foldTree (T x s t) e = f x (foldTree s (foldTree t e))++foldr' f e E = e+foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs)+  where foldTree (L x) e = f x $! e+        foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e))++foldl f e E = e+foldl f e (C _ t xs) = foldl f (foldTree e t) xs+  where foldTree e (L x) = f e x+        foldTree e (T x s t) = foldTree (foldTree (f e x) s) t++foldl' f e E = e+foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs+  where foldTree e (L x) = e `seq` f e x+        foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t++reduce1 f xs = case lview xs of+                 Nothing      -> error "RandList.reduce1: empty seq"+                 Just (x, xs) -> red1 x xs+  where red1 x E = x+        red1 x (C j t xs) = red1 (redTree x t) xs++        redTree x (L y) = f x y+        redTree x (T y s t) = redTree (redTree (f x y) s) t++reduce1' f xs = case lview xs of+                  Nothing      -> error "RandList.reduce1': empty seq"+                  Just (x, xs) -> red1 x xs+  where red1 x E = x+        red1 x (C j t xs) = (red1 $! (redTree x t)) xs++        redTree x (L y) = x `seq` y `seq` f x y+        redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t+++inBounds i xs = inb xs i+  where inb E i = False+        inb (C j t xs) i+          | i < j     = (i >= 0)+          | otherwise = inb xs (i - j)++lookup i xs = runIdentity (lookupM i xs)++lookupM i xs = look xs i+  where look E i = fail "RandList.lookup bad subscript"+        look (C j t xs) i+            | i < j     = lookTree j t i+            | otherwise = look xs (i - j)++        lookTree _ (L x) i+            | i == 0    = return x+            | otherwise = nothing+        lookTree j (T x s t) i+            | i > k  = lookTree k t (i - 1 - k)+            | i /= 0 = lookTree k s (i - 1)+            | otherwise = return x+          where k = half j+	nothing = fail "RandList.lookup: not found"++lookupWithDefault d i xs = look xs i+  where look E i = d+        look (C j t xs) i+            | i < j     = lookTree j t i+            | otherwise = look xs (i - j)++        lookTree _ (L x) i+            | i == 0    = x+            | otherwise = d+        lookTree j (T x s t) i+            | i > k   = lookTree k t (i - 1 - k)+            | i /= 0  = lookTree k s (i - 1)+            | otherwise = x+          where k = half j++update i y xs = upd i xs+  where upd i E = E+        upd i (C j t xs)+            | i < j     = C j (updTree i j t) xs+            | otherwise = C j t (upd (i - j) xs)++        updTree i j t@(L x)+            | i == 0    = L y+            | otherwise = t+        updTree i j (T x s t)+            | i > k   = T x s (updTree (i - 1 - k) k t)+            | i /= 0  = T x (updTree (i - 1) k s) t+            | otherwise = T y s t+          where k = half j++adjust f i xs = adj i xs+  where adj i E = E+        adj i (C j t xs)+            | i < j     = C j (adjTree i j t) xs+            | otherwise = C j t (adj (i - j) xs)++        adjTree i j t@(L x)+            | i == 0    = L (f x)+            | otherwise = t+        adjTree i j (T x s t)+            | i > k  = T x s (adjTree (i - 1 - k) k t)+            | i /= 0 = T x (adjTree (i - 1) k s) t+            | otherwise = T (f x) s t+          where k = half j++drop n xs = if n < 0 then xs else drp n xs+  where drp i E = E+        drp i (C j t xs)+            | i < j     = drpTree i j t xs+            | otherwise = drp (i - j) xs++        drpTree 0 j t xs = C j t xs+        drpTree i j (L x) xs = error "RandList.drop: bug.  Impossible case!"+        drpTree i j (T x s t) xs+            | i > k     = drpTree (i - 1 - k) k t xs+            | otherwise = drpTree (i - 1) k s (C k t xs)+          where k = half j++strict s@E = s+strict s@(C j t xs) = strictTree t `seq` strict xs `seq` s++strictTree t@(L x) = t+strictTree t@(T x l r) = strictTree l `seq` strictTree r `seq` t++strictWith f s@E = s+strictWith f s@(C j t xs) = strictWithTree f t `seq` strictWith f xs `seq` s++strictWithTree f t@(L x) = f x `seq` t+strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t+++-- the remaining functions all use defaults++rcons = rconsUsingFoldr+append = appendUsingFoldr+rview = rviewDefault+rtail = rtailUsingLview+rtailM = rtailMUsingLview+concat = concatUsingFoldr+reverse = reverseUsingReverseOnto+fromList = fromListUsingCons+toList = toListUsingFoldr+concatMap = concatMapUsingFoldr+foldr1  = foldr1UsingLview+foldr1' = foldr1'UsingLview+foldl1  = foldl1UsingFoldl+foldl1' = foldl1'UsingFoldl'+reducer  = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel  = reducelUsingReduce1+reducel' = reducel'UsingReduce1'+mapWithIndex = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+take = takeUsingLists+splitAt = splitAtDefault+filter = filterUsingFoldr+partition = partitionUsingFoldr+subseq = subseqDefault+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview++-- for zips, could optimize by calculating which one is shorter and+-- retaining its shape++zip = zipUsingLists+zip3 = zip3UsingLists+zipWith = zipWithUsingLists+zipWith3 = zipWith3UsingLists+unzip = unzipUsingLists+unzip3 = unzip3UsingLists+unzipWith = unzipWithUsingLists+unzipWith3 = unzipWith3UsingLists++-- invariants: +--   * list of complete binary trees in non-decreasing+--     order by size+--   * first argument to 'C' is the number+--     of nodes in the tree++structuralInvariant E = True+structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s++   where checkTree 1 (L _) = True+         checkTree w (T _ l r) = +             let w' = (w - 1) `div` 2 +             in w' > 0 && checkTree w' l && checkTree w' r+         checkTree _ _ = False++         checkSeq x E = True+         checkSeq x (C y t s) = +	     x <= y && checkTree y t && checkSeq y s+++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = do xs <- arbitrary+                 return (fromList xs)++  coarbitrary xs = coarbitrary (toList xs)++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/RevSeq.hs view
@@ -0,0 +1,382 @@+-- |+--   Module      :  Data.Edison.Seq.RevSeq+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module defines a sequence adaptor @Rev s@.+--   If @s@ is a sequence type constructor, then @Rev s@+--   is a sequence type constructor that is identical to @s@,+--   except that it is kept in the opposite order.+--   Also keeps explicit track of the size of the sequence,+--   similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq".+--+--   This module is most useful when s is a sequence type+--   that offers fast access to the front but slow access+--   to the rear, and your application needs the opposite+--   (i.e., fast access to the rear but slow access to the+--   front).+--+--   All time complexities are determined by the underlying+--   sequence, except that the complexities for accessing+--   the left and right sides of the sequence are exchanged,+--   and size becomes @O( 1 )@.++module Data.Edison.Seq.RevSeq (+    -- * Rev Sequence Type+    Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName,instanceName,++    -- * Other supported operations+    fromSeq,toSeq++) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Seq.Defaults -- only used by concatMap+import Control.Monad+import Data.Monoid+import Test.QuickCheck+++-- signatures for exported functions+moduleName     :: String+instanceName   :: S.Sequence s => Rev s a -> String+empty          :: S.Sequence s => Rev s a+singleton      :: S.Sequence s => a -> Rev s a+lcons          :: S.Sequence s => a -> Rev s a -> Rev s a+rcons          :: S.Sequence s => a -> Rev s a -> Rev s a+append         :: S.Sequence s => Rev s a -> Rev s a -> Rev s a+lview          :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a)+lhead          :: S.Sequence s => Rev s a -> a+lheadM         :: (S.Sequence s, Monad m) => Rev s a -> m a+ltail          :: S.Sequence s => Rev s a -> Rev s a+ltailM         :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a)+rview          :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a)+rhead          :: S.Sequence s => Rev s a -> a+rheadM         :: (S.Sequence s, Monad m) => Rev s a -> m a+rtail          :: S.Sequence s => Rev s a -> Rev s a+rtailM         :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a)+null           :: S.Sequence s => Rev s a -> Bool+size           :: S.Sequence s => Rev s a -> Int+concat         :: S.Sequence s => Rev s (Rev s a) -> Rev s a+reverse        :: S.Sequence s => Rev s a -> Rev s a+reverseOnto    :: S.Sequence s => Rev s a -> Rev s a -> Rev s a+fromList       :: S.Sequence s => [a] -> Rev s a+toList         :: S.Sequence s => Rev s a -> [a]+map            :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b+concatMap      :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b+fold           :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b+fold'          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b+fold1          :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+fold1'         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+foldr          :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b+foldl          :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b+foldr1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+foldl1         :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+reducer        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a+reducel        :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a+reduce1        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b+foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b+foldr1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+foldl1'        :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a+reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a+reduce1'       :: S.Sequence s => (a -> a -> a) -> Rev s a -> a+copy           :: S.Sequence s => Int -> a -> Rev s a+inBounds       :: S.Sequence s => Int -> Rev s a -> Bool+lookup         :: S.Sequence s => Int -> Rev s a -> a+lookupM        :: (S.Sequence s, Monad m) => Int -> Rev s a -> m a+lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a+update         :: S.Sequence s => Int -> a -> Rev s a -> Rev s a+adjust         :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a+mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b+foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b+foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b+foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b+foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b+take           :: S.Sequence s => Int -> Rev s a -> Rev s a+drop           :: S.Sequence s => Int -> Rev s a -> Rev s a+splitAt        :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)+subseq         :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a+filter         :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a+partition      :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)+takeWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a+dropWhile      :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a+splitWhile     :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)+zip            :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b)+zip3           :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c)+zipWith        :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c+zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d+unzip          :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b)+unzip3         :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c)+unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)+unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)+strict         :: S.Sequence s => Rev s a -> Rev s a+strictWith     :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a+structuralInvariant :: S.Sequence s => Rev s a -> Bool++-- bonus functions, not in Sequence signature+fromSeq        :: S.Sequence s => s a -> Rev s a+toSeq          :: S.Sequence s => Rev s a -> s a+++moduleName = "Data.Edison.Seq.RevSeq"+instanceName (N m s) = "RevSeq(" ++ S.instanceName s ++ ")"++data Rev s a = N !Int (s a)+  -- The Int is the size minus one.  The "minus one" makes indexing+  -- calculations easier.++fromSeq xs = N (S.size xs - 1) xs+toSeq (N m xs) = xs++empty = N (-1) S.empty+singleton x = N 0 (S.singleton x)+lcons x (N m xs) = N (m+1) (S.rcons x xs)+rcons x (N m xs) = N (m+1) (S.lcons x xs)+append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs)++lview (N m xs) = case S.rview xs of+                   Nothing     -> fail "RevSeq.lview: empty sequence"+                   Just (x,xs) -> return (x, N (m-1) xs)++lhead (N m xs) = S.rhead xs++lheadM (N m xs) = S.rheadM xs++ltail (N (-1) xs) = error "RevSeq.ltail: empty sequence"+ltail (N m xs) = N (m-1) (S.rtail xs)++ltailM (N (-1) xs) = fail "RevSeq.ltailM: empty sequence"+ltailM (N m xs) = return (N (m-1) (S.rtail xs))++rview (N m xs) = case S.lview xs of+                   Nothing     -> fail "RevSeq.rview: empty sequence"+                   Just (x,xs) -> return (x, N (m-1) xs)+ +rhead (N m xs) = S.lhead xs++rheadM (N m xs) = S.lheadM xs++rtail (N (-1) xs) = error "RevSeq.rtail: empty sequence"+rtail (N m xs) = N (m-1) (S.ltail xs)++rtailM (N (-1) xs) = fail "RevSeq.rtailM: empty sequence"+rtailM (N m xs) = return (N (m-1) (S.ltail xs))++null (N m xs) = m == -1+size (N m xs) = m+1+concat (N m xss) = fromSeq (S.concat (S.map toSeq xss))+reverse (N m xs) = N m (S.reverse xs)+reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs))+fromList = fromSeq . S.fromList . L.reverse+toList (N m xs) = S.foldl (flip (:)) [] xs+map f (N m xs) = N m (S.map f xs)++concatMap = concatMapUsingFoldr -- only function that uses a default++fold f e (N m xs) = S.fold f e xs+fold' f e (N m xs) = S.fold' f e xs+fold1 f (N m xs) = S.fold1 f xs+fold1' f (N m xs) = S.fold1' f xs+foldr f e (N m xs) = S.foldl (flip f) e xs+foldr' f e (N m xs) = S.foldl' (flip f) e xs+foldl f e (N m xs) = S.foldr (flip f) e xs+foldl' f e (N m xs) = S.foldr' (flip f) e xs+foldr1 f (N m xs) = S.foldl1 (flip f) xs+foldr1' f (N m xs) = S.foldl1' (flip f) xs+foldl1 f (N m xs) = S.foldr1 (flip f) xs+foldl1' f (N m xs) = S.foldr1' (flip f) xs+reducer f e (N m xs) = S.reducel (flip f) e xs+reducer' f e (N m xs) = S.reducel' (flip f) e xs+reducel f e (N m xs) = S.reducer (flip f) e xs+reducel' f e (N m xs) = S.reducer' (flip f) e xs+reduce1 f (N m xs) = S.reduce1 (flip f) xs+reduce1' f (N m xs) = S.reduce1' (flip f) xs++copy n x +    | n <= 0 = empty+    | otherwise = N (n-1) (S.copy n x)++inBounds i (N m xs) = (i >= 0) && (i <= m)+lookup i (N m xs) = S.lookup (m-i) xs+lookupM i (N m xs) = S.lookupM (m-i) xs+lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs+update i x (N m xs) = N m (S.update (m-i) x xs)+adjust f i (N m xs) = N m (S.adjust f (m-i) xs)+mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs)++foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs+  where f' xs i x = f (m-i) x xs+foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs+  where f' xs i x = f (m-i) x xs++foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs+  where f' i x xs = f xs (m-i) x+foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs+  where f' i x xs = f xs (m-i) x++take i original@(N m xs)+  | i <= 0 = empty+  | i >  m = original+  | otherwise = N (i-1) (S.drop (m-i+1) xs)++drop i original@(N m xs)+  | i <= 0 = original+  | i >  m = empty+  | otherwise = N (m-i) (S.take (m-i+1) xs)++splitAt i original@(N m xs)+  | i <= 0 = (empty, original)+  | i >  m = (original, empty)+  | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs+                in (N (i-1) zs, N (m-i) ys)++subseq i len original@(N m xs)+  | i <= 0 = take len original+  | i >  m || len <= 0 = empty+  | i+len > m = N (m-i) (S.take (m-i+1) xs)+  | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs)++filter p = fromSeq . S.filter p . toSeq++partition p (N m xs) = (N (k-1) ys, N (m-k) zs)+  where (ys,zs) = S.partition p xs+        k = S.size ys++takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq+dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq++splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs))+  where (ys,zs) = S.splitWhile p (S.reverse xs)+        k = S.size ys++zip (N m xs) (N n ys)+  | m < n = N m (S.zip xs (S.drop (n-m) ys))+  | m > n = N n (S.zip (S.drop (m-n) xs) ys)+  | otherwise = N m (S.zip xs ys)+zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs')+  where k = min l (min m n)+        xs' = if l == k then xs else S.drop (l-k) xs+        ys' = if m == k then ys else S.drop (m-k) ys+        zs' = if n == k then zs else S.drop (n-k) zs++zipWith f (N m xs) (N n ys)+  | m < n = N m (S.zipWith f xs (S.drop (n-m) ys))+  | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys)+  | otherwise = N m (S.zipWith f xs ys)+zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs')+  where k = min l (min m n)+        xs' = if l == k then xs else S.drop (l-k) xs+        ys' = if m == k then ys else S.drop (m-k) ys+        zs' = if n == k then zs else S.drop (n-k) zs++unzip (N m xys) = (N m xs, N m ys)+  where (xs,ys) = S.unzip xys++unzip3 (N m xyzs) = (N m xs, N m ys, N m zs)+  where (xs,ys,zs) = S.unzip3 xyzs++unzipWith f g (N m xys) = (N m xs, N m ys)+  where (xs,ys) = S.unzipWith f g xys++unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs)+  where (xs,ys,zs) = S.unzipWith3 f g h xyzs++strict s@(N i s') = S.strict s' `seq` s+strictWith f s@(N i s') = S.strictWith f s' `seq` s++structuralInvariant (N i s) = i == ((S.size s) - 1)++-- instances++instance S.Sequence s => S.Sequence (Rev s) where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName = instanceName}++instance S.Sequence s => Functor (Rev s) where+  fmap = map++instance S.Sequence s => Monad (Rev s) where+  return = singleton+  xs >>= k = concatMap k xs++instance S.Sequence s => MonadPlus (Rev s) where+  mplus = append+  mzero = empty++instance Eq (s a) => Eq (Rev s a) where+  (N m xs) == (N n ys) = (m == n) && (xs == ys)++instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where+  compare = defaultCompare++instance (S.Sequence s, Show (s a)) => Show (Rev s a) where+  showsPrec i xs rest+     | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]+     | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]++instance (S.Sequence s, Read (s a)) => Read (Rev s a) where+  readsPrec i xs = maybeParens p xs+      where p xs = tokenMatch (moduleName++".fromSeq") xs+                     >>= readsPrec 10+                     >>= \(l,rest) -> return (fromSeq l,rest)++instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Rev s a) where+  arbitrary = do xs <- arbitrary+                 return (fromSeq xs)++  coarbitrary xs = coarbitrary (toSeq xs)++instance S.Sequence s => Monoid (Rev s a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/SimpleQueue.hs view
@@ -0,0 +1,369 @@+-- |+--   Module      :  Data.Edison.Seq.SimpleQueue+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   Simple Queues.  All operations have running times as listed in+--   "Data.Edison.Seq" except for the following:+--+--   * rcons, fromList   @O( 1 )@+--+--   * lview, ltail*   @O( 1 )@ if single threaded, @O( n )@ otherwise+--+--   * inBounds, lookup, update, drop, splitAt  @O( n )@+--+--   /References:/+--+--   * Chris Okasaki. /Purely Functional Data Structures/. 1998.+--     Section 5.2.+--+--   * F. Warren Burton. \"An efficient functional implementation of FIFO queues\".+--     /Information Processing Letters/, 14(5):205-206, July 1982.++module Data.Edison.Seq.SimpleQueue (+    -- * Sequence Type+    Seq, -- instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S ( Sequence(..) )+import Data.Edison.Seq.Defaults+import qualified Data.Edison.Seq.ListSeq as L+import Data.Monoid+import Control.Monad+import Test.QuickCheck++-- signatures for exported functions+moduleName     :: String+empty          :: Seq a+singleton      :: a -> Seq a+lcons          :: a -> Seq a -> Seq a+rcons          :: a -> Seq a -> Seq a+append         :: Seq a -> Seq a -> Seq a+lview          :: (Monad m) => Seq a -> m (a, Seq a)+lhead          :: Seq a -> a+lheadM         :: (Monad m) => Seq a -> m a+ltail          :: Seq a -> Seq a+ltailM         :: (Monad m) => Seq a -> m (Seq a)+rview          :: (Monad m) => Seq a -> m (a, Seq a)+rhead          :: Seq a -> a+rheadM         :: (Monad m) => Seq a -> m a+rtail          :: Seq a -> Seq a+rtailM         :: (Monad m) => Seq a -> m (Seq a)+null           :: Seq a -> Bool+size           :: Seq a -> Int+concat         :: Seq (Seq a) -> Seq a+reverse        :: Seq a -> Seq a+reverseOnto    :: Seq a -> Seq a -> Seq a+fromList       :: [a] -> Seq a+toList         :: Seq a -> [a]+map            :: (a -> b) -> Seq a -> Seq b+concatMap      :: (a -> Seq b) -> Seq a -> Seq b+fold           :: (a -> b -> b) -> b -> Seq a -> b+fold'          :: (a -> b -> b) -> b -> Seq a -> b+fold1          :: (a -> a -> a) -> Seq a -> a+fold1'         :: (a -> a -> a) -> Seq a -> a+foldr          :: (a -> b -> b) -> b -> Seq a -> b+foldl          :: (b -> a -> b) -> b -> Seq a -> b+foldr1         :: (a -> a -> a) -> Seq a -> a+foldl1         :: (a -> a -> a) -> Seq a -> a+reducer        :: (a -> a -> a) -> a -> Seq a -> a+reducel        :: (a -> a -> a) -> a -> Seq a -> a+reduce1        :: (a -> a -> a) -> Seq a -> a+foldr'         :: (a -> b -> b) -> b -> Seq a -> b+foldl'         :: (b -> a -> b) -> b -> Seq a -> b+foldr1'        :: (a -> a -> a) -> Seq a -> a+foldl1'        :: (a -> a -> a) -> Seq a -> a+reducer'       :: (a -> a -> a) -> a -> Seq a -> a+reducel'       :: (a -> a -> a) -> a -> Seq a -> a+reduce1'       :: (a -> a -> a) -> Seq a -> a+copy           :: Int -> a -> Seq a+inBounds       :: Int -> Seq a -> Bool+lookup         :: Int -> Seq a -> a+lookupM        :: (Monad m) => Int -> Seq a -> m a+lookupWithDefault :: a -> Int -> Seq a -> a+update         :: Int -> a -> Seq a -> Seq a+adjust         :: (a -> a) -> Int -> Seq a -> Seq a+mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b+take           :: Int -> Seq a -> Seq a+drop           :: Int -> Seq a -> Seq a+splitAt        :: Int -> Seq a -> (Seq a, Seq a)+subseq         :: Int -> Int -> Seq a -> Seq a+filter         :: (a -> Bool) -> Seq a -> Seq a+partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+takeWhile      :: (a -> Bool) -> Seq a -> Seq a+dropWhile      :: (a -> Bool) -> Seq a -> Seq a+splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+zip            :: Seq a -> Seq b -> Seq (a,b)+zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+unzip          :: Seq (a,b) -> (Seq a, Seq b)+unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)+unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)+unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)+strict         :: Seq a -> Seq a+strictWith     :: (a -> b) -> Seq a -> Seq a+structuralInvariant :: Seq a -> Bool++moduleName = "Data.Edison.Seq.SimpleQueue"+++data Seq a = Q [a] [a]+  -- invariant: front empty only if rear also empty++-- not exported+makeQ [] ys = Q (L.reverse ys) []+makeQ xs ys = Q xs ys++empty = Q [] []+singleton x = Q [x] []+lcons x (Q xs ys) = Q (x:xs) ys++rcons y (Q [] _) = Q [y] []+rcons y (Q xs ys) = Q xs (y:ys)++append (Q xs1 ys1) (Q xs2 ys2) =+    Q (xs1 ++ L.reverseOnto ys1 xs2) ys2++lview (Q [] _) = fail "SimpleQueue.lview: empty sequence"+lview (Q [x] ys) = return (x, Q (L.reverse ys) [])+lview (Q (x:xs) ys) = return (x, Q xs ys)++lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence"+lhead (Q (x:xs) _) = x++lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence"+lheadM (Q (x:xs) _) = return x++ltail (Q [x] ys) = Q (L.reverse ys) []+ltail (Q (x:xs) ys) = Q xs ys+ltail q@(Q [] _) = error "SimpleQueue.ltail: empty sequence"++ltailM (Q [x] ys) = return (Q (L.reverse ys) [])+ltailM (Q (x:xs) ys) = return (Q xs ys)+ltailM q@(Q [] _) = fail "SimpleQueue.ltailM: empty sequence"++rview (Q xs (y:ys)) = return (y, Q xs ys)+rview (Q xs []) =+  case L.rview xs of+    Nothing      -> fail "SimpleQueue.rview: empty sequence"+    Just (x,xs') -> return (x, Q xs' [])++rhead (Q xs (y:ys)) = y+rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence"+rhead (Q xs []) = L.rhead xs++rheadM (Q xs (y:ys)) = return y+rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence"+rheadM (Q xs []) = return (L.rhead xs)++rtail (Q xs (y:ys)) = Q xs ys+rtail q@(Q [] []) = error "SimpleQueue.rtail: empty sequence"+rtail (Q xs []) = Q (L.rtail xs) []++rtailM (Q xs (y:ys)) = return (Q xs ys)+rtailM q@(Q [] []) = fail "SimpleQueue.rtailM: empty sequence"+rtailM (Q xs []) = return (Q (L.rtail xs) [])++null (Q [] _) = True+null _ = False++size (Q xs ys) = length xs + length ys++reverse (Q xs []) = Q (L.reverse xs) []+reverse (Q xs ys) = Q ys xs++reverseOnto (Q xs1 ys1) (Q xs2 ys2) =+    Q (ys1 ++ L.reverseOnto xs1 xs2) ys2++fromList xs = Q xs []++toList (Q xs []) = xs+toList (Q xs ys) = xs ++ L.reverse ys++map f (Q xs ys) = Q (L.map f xs) (L.map f ys)++-- local fn on lists+revfoldr f e [] = e+revfoldr f e (x:xs) = revfoldr f (f x e) xs++revfoldr' f e [] = e+revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs++-- local fn on lists+revfoldl f e [] = e+revfoldl f e (x:xs) = f (revfoldl f e xs) x++revfoldl' f e [] = e+revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x++fold   f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs+fold'  f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs+fold1  = fold1UsingFold+fold1' = fold1'UsingFold'++foldr  f e (Q xs ys) = L.foldr  f (revfoldr  f e ys) xs+foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs++foldl  f e (Q xs ys) = revfoldl  f (L.foldl  f e xs) ys+foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys++foldr1  f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs+foldr1  f (Q [] []) = error "SimpleQueue.foldr1: empty sequence"+foldr1  f (Q xs []) = L.foldr1 f xs++foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs+foldr1' f (Q [] []) = error "SimpleQueye.foldr1': empty sequence"+foldr1' f (Q xs []) = L.foldr1' f xs++foldl1  f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys+foldl1  f (Q [] _) = error "SimpleQueue.foldl1: empty sequence"++foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys+foldl1' f (Q [] _) = error "SimpleQueue.foldl1': empty sequence"++filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys)++partition p (Q xs ys)+  = (makeQ xsT ysT, makeQ xsF ysF)+ where+   (xsT,xsF) = L.partition p xs+   (ysT,ysF) = L.partition p ys++strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s+strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s++-- the remaining functions all use defaults++concat = concatUsingFoldr+concatMap = concatMapUsingFoldr+reducer  = reducerUsingReduce1+reducer' = reducer'UsingReduce1'+reducel  = reducelUsingReduce1+reducel' = reducel'UsingReduce1'+reduce1  = reduce1UsingLists+reduce1' = reduce1'UsingLists+copy = copyUsingLists+inBounds = inBoundsUsingLookupM+lookup = lookupUsingLookupM+lookupM = lookupMUsingDrop+lookupWithDefault = lookupWithDefaultUsingLookupM+update = updateUsingAdjust+adjust = adjustUsingLists+mapWithIndex = mapWithIndexUsingLists+foldrWithIndex  = foldrWithIndexUsingLists+foldrWithIndex' = foldrWithIndex'UsingLists+foldlWithIndex  = foldlWithIndexUsingLists+foldlWithIndex' = foldlWithIndex'UsingLists+take = takeUsingLists+drop = dropUsingLists+splitAt = splitAtDefault+subseq = subseqDefault+takeWhile = takeWhileUsingLview+dropWhile = dropWhileUsingLview+splitWhile = splitWhileUsingLview+zip = zipUsingLists+zip3 = zip3UsingLists+zipWith = zipWithUsingLists+zipWith3 = zipWith3UsingLists+unzip = unzipUsingLists+unzip3 = unzip3UsingLists+unzipWith = unzipWithUsingLists+unzipWith3 = unzipWith3UsingLists++-- invariant: +--   * front empty only if rear also empty++structuralInvariant (Q x y) = not (L.null x) || L.null y++-- instances++instance S.Sequence Seq where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName s = moduleName}++instance Functor Seq where+  fmap = map++instance Monad Seq where+  return = singleton+  xs >>= k = concatMap k xs++instance MonadPlus Seq where+  mplus = append+  mzero = empty++instance Eq a => Eq (Seq a) where+  q1 == q2 = toList q1 == toList q2++instance Ord a => Ord (Seq a) where+  compare = defaultCompare++instance Show a => Show (Seq a) where+  showsPrec = showsPrecUsingToList++instance Read a => Read (Seq a) where+  readsPrec = readsPrecUsingFromList++instance Arbitrary a => Arbitrary (Seq a) where+  arbitrary = do xs <- arbitrary+                 ys <- arbitrary+                 return (if L.null xs then Q ys [] else Q xs ys)++  coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys++instance Monoid (Seq a) where+  mempty  = empty+  mappend = append
+ src/Data/Edison/Seq/SizedSeq.hs view
@@ -0,0 +1,355 @@+-- |+--   Module      :  Data.Edison.Seq.SizedSeq+--   Copyright   :  Copyright (c) 1998-1999 Chris Okasaki+--   License     :  MIT; see COPYRIGHT file for terms and conditions+--+--   Maintainer  :  robdockins AT fastmail DOT fm+--   Stability   :  stable+--   Portability :  GHC, Hugs (MPTC and FD)+--+--   This module defines a sequence adaptor @Sized s@.+--   If @s@ is a sequence type constructor, then @Sized s@+--   is a sequence type constructor that is identical to @s@,+--   except that it also keeps track of the current size of+--   each sequence.+--+--   All time complexities are determined by the underlying+--   sequence, except that size becomes @O( 1 )@.++module Data.Edison.Seq.SizedSeq (+    -- * Sized Sequence Type+    Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus++    -- * Sequence Operations+    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,+    lheadM,ltailM,rheadM,rtailM,+    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,+    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',+    reducer,reducer',reducel,reducel',reduce1,reduce1',+    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,+    mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',+    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,+    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,+    strict, strictWith,++    -- * Unit testing+    structuralInvariant,++    -- * Documentation+    moduleName,instanceName,++    -- * Other supported operations+    fromSeq,toSeq+) where++import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,+                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,+                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)++import Data.Edison.Prelude+import qualified Data.Edison.Seq as S+import qualified Data.Edison.Seq.ListSeq as L+import Data.Edison.Seq.Defaults -- only used by concatMap+import Data.Monoid+import Control.Monad+import Test.QuickCheck+++-- signatures for exported functions+moduleName     :: String+instanceName   :: S.Sequence s => Sized s a -> String+empty          :: S.Sequence s => Sized s a+singleton      :: S.Sequence s => a -> Sized s a+lcons          :: S.Sequence s => a -> Sized s a -> Sized s a+rcons          :: S.Sequence s => a -> Sized s a -> Sized s a+append         :: S.Sequence s => Sized s a -> Sized s a -> Sized s a+lview          :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a)+lhead          :: S.Sequence s => Sized s a -> a+lheadM         :: (S.Sequence s, Monad m) => Sized s a -> m a+ltail          :: S.Sequence s => Sized s a -> Sized s a+ltailM         :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a)+rview          :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a)+rhead          :: S.Sequence s => Sized s a -> a+rheadM         :: (S.Sequence s, Monad m) => Sized s a -> m a+rtail          :: S.Sequence s => Sized s a -> Sized s a+rtailM         :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a)+null           :: S.Sequence s => Sized s a -> Bool+size           :: S.Sequence s => Sized s a -> Int+concat         :: S.Sequence s => Sized s (Sized s a) -> Sized s a+reverse        :: S.Sequence s => Sized s a -> Sized s a+reverseOnto    :: S.Sequence s => Sized s a -> Sized s a -> Sized s a+fromList       :: S.Sequence s => [a] -> Sized s a+toList         :: S.Sequence s => Sized s a -> [a]+map            :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b+concatMap      :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b+fold           :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b+fold'          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b+fold1          :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+fold1'         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+foldr          :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b+foldl          :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b+foldr1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+foldl1         :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+reducer        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a+reducel        :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a+reduce1        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+foldr'         :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b+foldl'         :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b+foldr1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+foldl1'        :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+reducer'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a+reducel'       :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a+reduce1'       :: S.Sequence s => (a -> a -> a) -> Sized s a -> a+copy           :: S.Sequence s => Int -> a -> Sized s a+inBounds       :: S.Sequence s => Int -> Sized s a -> Bool+lookup         :: S.Sequence s => Int -> Sized s a -> a+lookupM        :: (S.Sequence s, Monad m) => Int -> Sized s a -> m a+lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a+update         :: S.Sequence s => Int -> a -> Sized s a -> Sized s a+adjust         :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a+mapWithIndex   :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b+foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b+foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b+foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b+foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b+take           :: S.Sequence s => Int -> Sized s a -> Sized s a+drop           :: S.Sequence s => Int -> Sized s a -> Sized s a+splitAt        :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)+subseq         :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a+filter         :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a+partition      :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)+takeWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a+dropWhile      :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a+splitWhile     :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)+zip            :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b)+zip3           :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c)+zipWith        :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c+zipWith3       :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d+unzip          :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b)+unzip3         :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c)+unzipWith      :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)+unzipWith3     :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)+strict         :: S.Sequence s => Sized s a -> Sized s a+strictWith     :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a+structuralInvariant :: S.Sequence s => Sized s a -> Bool++-- bonus functions, not in Sequence signature+fromSeq        :: S.Sequence s => s a -> Sized s a+toSeq          :: S.Sequence s => Sized s a -> s a++++moduleName = "Data.Edison.Seq.SizedSeq"+instanceName (N n s) = "SizedSeq(" ++ S.instanceName s ++ ")"++data Sized s a = N !Int (s a)++fromSeq xs = N (S.size xs) xs+toSeq (N n xs) = xs++empty = N 0 S.empty+singleton x = N 1 (S.singleton x)+lcons x (N n xs) = N (n+1) (S.lcons x xs)+rcons x (N n xs) = N (n+1) (S.rcons x xs)+append (N m xs) (N n ys) = N (m+n) (S.append xs ys)++lview (N n xs) = case S.lview xs of+                   Nothing     -> fail "SizedSeq.lview: empty sequence"+                   Just (x,xs) -> return (x, N (n-1) xs)++lhead (N n xs) = S.lhead xs++lheadM (N n xs) = S.lheadM xs++ltail (N 0 xs) = error "SizedSeq.ltail: empty sequence"+ltail (N n xs) = N (n-1) (S.ltail xs)++ltailM (N 0 xs) = fail "SizedSeq.ltailM: empty sequence"+ltailM (N n xs) = return (N (n-1) (S.ltail xs))++rview (N n xs) = case S.rview xs of+                   Nothing     -> fail "SizedSeq.rview: empty sequence"+                   Just (x,xs) -> return (x, N (n-1) xs)+ +rhead (N n xs) = S.rhead xs++rheadM (N n xs) = S.rheadM xs++rtail (N 0 xs) = error "SizedSeq.rtail: empty sequence"+rtail (N n xs) = N (n-1) (S.rtail xs)++rtailM (N 0 xs) = fail "SizedSeq.rtailM: empty sequence"+rtailM (N n xs) = return (N (n-1) (S.rtail xs))++null (N n xs) = n == 0+size (N n xs) = n+concat (N n xss) = fromSeq (S.concat (S.map toSeq xss))+reverse (N n xs) = N n (S.reverse xs)+reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys)+fromList = fromSeq . S.fromList+toList (N n xs) = S.toList xs+map f (N n xs) = N n (S.map f xs)++concatMap = concatMapUsingFoldr -- only function that uses a default++fold  f e (N n xs) = S.fold f e xs+fold' f e (N n xs) = S.fold' f e xs+fold1 f  (N n xs) = S.fold1 f xs+fold1' f (N n xs) = S.fold1' f xs+foldr  f e (N n xs) = S.foldr f e xs+foldr' f e (N n xs) = S.foldr' f e xs+foldl  f e (N n xs) = S.foldl f e xs+foldl' f e (N n xs) = S.foldl' f e xs+foldr1  f (N n xs) = S.foldr1 f xs+foldr1' f (N n xs) = S.foldr1' f xs+foldl1  f (N n xs) = S.foldl1 f xs+foldl1' f (N n xs) = S.foldl1' f xs+reducer  f e (N n xs) = S.reducer f e xs+reducer' f e (N n xs) = S.reducer' f e xs+reducel  f e (N n xs) = S.reducel f e xs+reducel' f e (N n xs) = S.reducel' f e xs+reduce1  f (N n xs) = S.reduce1 f xs+reduce1' f (N n xs) = S.reduce1' f xs++copy n x +    | n <= 0 = empty+    | otherwise = N n (S.copy n x)++inBounds i (N n xs) = (i >= 0) && (i < n)+lookup i (N n xs) = S.lookup i xs+lookupM i (N n xs) = S.lookupM i xs+lookupWithDefault d i (N n xs) = S.lookupWithDefault d i xs+update i x (N n xs) = N n (S.update i x xs)+adjust f i (N n xs) = N n (S.adjust f i xs)+mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs)+foldrWithIndex  f e (N n xs) = S.foldrWithIndex f e xs+foldrWithIndex' f e (N n xs) = S.foldrWithIndex' f e xs+foldlWithIndex  f e (N n xs) = S.foldlWithIndex f e xs+foldlWithIndex' f e (N n xs) = S.foldlWithIndex' f e xs++take i original@(N n xs)+  | i <= 0 = empty+  | i >= n = original+  | otherwise = N i (S.take i xs)++drop i original@(N n xs)+  | i <= 0 = original+  | i >= n = empty+  | otherwise = N (n-i) (S.drop i xs)++splitAt i original@(N n xs)+  | i <= 0 = (empty, original)+  | i >= n = (original, empty)+  | otherwise = let (ys,zs) = S.splitAt i xs+                in (N i ys, N (n-i) zs)++subseq i len original@(N n xs)+  | i <= 0 = take len original+  | i >= n || len <= 0 = empty+  | i+len >= n = N (n-i) (S.drop i xs)+  | otherwise = N len (S.subseq i len xs)++filter p = fromSeq . S.filter p . toSeq++partition p (N n xs) = (N m ys, N (n-m) zs)+  where (ys,zs) = S.partition p xs+        m = S.size ys++takeWhile p = fromSeq . S.takeWhile p . toSeq+dropWhile p = fromSeq . S.dropWhile p . toSeq++splitWhile p (N n xs) = (N m ys, N (n-m) zs)+  where (ys,zs) = S.splitWhile p xs+        m = S.size ys++zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys)+zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs)++zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys)+zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs)++unzip (N n xys) = (N n xs, N n ys)+  where (xs,ys) = S.unzip xys++unzip3 (N n xyzs) = (N n xs, N n ys, N n zs)+  where (xs,ys,zs) = S.unzip3 xyzs++unzipWith f g (N n xys) = (N n xs, N n ys)+  where (xs,ys) = S.unzipWith f g xys++unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs)+  where (xs,ys,zs) = S.unzipWith3 f g h xyzs++strict s@(N i s') = S.strict s' `seq` s+strictWith f s@(N i s') = S.strictWith f s' `seq` s++structuralInvariant (N i s) = i == S.size s++-- instances++instance S.Sequence s => S.Sequence (Sized s) where+  {lcons = lcons; rcons = rcons;+   lview = lview; lhead = lhead; ltail = ltail;+   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;+   rview = rview; rhead = rhead; rtail = rtail; null = null;+   size = size; concat = concat; reverse = reverse; +   reverseOnto = reverseOnto; fromList = fromList; toList = toList;+   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';+   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';+   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';+   reducer = reducer; reducer' = reducer'; reducel = reducel;+   reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';+   copy = copy; inBounds = inBounds; lookup = lookup;+   lookupM = lookupM; lookupWithDefault = lookupWithDefault;+   update = update; adjust = adjust; mapWithIndex = mapWithIndex;+   foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';+   foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';+   take = take; drop = drop; splitAt = splitAt; subseq = subseq;+   filter = filter; partition = partition; takeWhile = takeWhile;+   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;+   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;+   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;+   strict = strict; strictWith = strictWith;+   structuralInvariant = structuralInvariant; instanceName = instanceName}++instance S.Sequence s => Functor (Sized s) where+  fmap = map++instance S.Sequence s => Monad (Sized s) where+  return = singleton+  xs >>= k = concatMap k xs++instance S.Sequence s => MonadPlus (Sized s) where+  mplus = append+  mzero = empty+++instance Eq (s a) => Eq (Sized s a) where+  (N m xs) == (N n ys) = (m == n) && (xs == ys)+  -- this is probably identical to the code that would be+  -- generated by "deriving (Eq)", but I wanted to be *sure*+  -- that the sizes were compared before the inner sequences++instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where+  compare = defaultCompare++instance (S.Sequence s, Show (s a)) => Show (Sized s a) where+  showsPrec i xs rest+    | i == 0    = L.concat [    moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]+    | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]++instance (S.Sequence s, Read (s a)) => Read (Sized s a) where+  readsPrec i xs = maybeParens p xs+      where p xs = tokenMatch (moduleName++".fromSeq") xs+                     >>= readsPrec 10+                     >>= \(l,rest) -> return (fromSeq l, rest)++instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Sized s a) where+  arbitrary = do xs <- arbitrary+                 return (fromSeq xs)++  coarbitrary xs = coarbitrary (toSeq xs)++instance S.Sequence s => Monoid (Sized s a) where+  mempty  = empty+  mappend = append