packages feed

perdure (empty) → 0.1.0

raw patch · 40 files changed

+3718/−0 lines, 40 filesdep +MonadRandomdep +QuickCheckdep +arraysetup-changed

Dependencies added: MonadRandom, QuickCheck, array, base, binary, bytestring, cognimeta-utils, collections-api, comonad-transformers, containers, cryptohash, data-binary-ieee754, data-lens, data-lens-fd, data-lens-template, deepseq, deepseq-th, filepath, ghc-prim, lrucache, mtl, perdure, primitive, stm, strict, tagged, template-haskell, time, transformers, unix

Files

+ LICENSE-2.0.txt view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ exe-src/Main.hs view
@@ -0,0 +1,56 @@+{-+Copyright 2010-2012 Cognimeta Inc.++Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at++     http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software distributed under the License is+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express+or implied. See the License for the specific language governing permissions and limitations under the License.+-}++{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeFamilies, TemplateHaskell #-}++module Main (+  main+) where++import Data.Int+import Data.Word+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Test.QuickCheck as QC+import Test.QuickCheck.Arbitrary+import System.Environment+import Language.Haskell.TH+import Database.Perdure.TestState+import Database.Perdure.TestPersistent+import Database.Perdure.TestStoreFile+import Database.Perdure.TestMap+import Cgm.TH.Label++import Cgm.Control.Profile++main :: IO ()+main = getArgs >>= argsMain++argsMain :: [String] -> IO ()+argsMain (x:xs) = maybe invalidArgs ($ xs) $ lookup x mains+argsMain [] = invalidArgs++invalidArgs :: IO ()+invalidArgs = putStrLn $ "Invalid arguments, first argument should be one of " ++ (show $ map fst mains)++mains :: [(String, [String] -> IO ())]+mains = [+    $(label 'testStoreFile),+  $(label 'testPersistent),+    $(label 'testPersistentMap),+  $(label 'testSeqPersistent),+    $(label 'testStates),+  $(label 'testStatesDag),+    $(label 'testMap)+  -- $(label 'testStatesDestroysRaw1),+  ]
+ perdure.cabal view
@@ -0,0 +1,243 @@+Name: perdure+version: 0.1.0+cabal-version: >= 1.8+build-type: Simple+license: OtherLicense+license-file: "LICENSE-2.0.txt"+copyright: (c) 2010-2012 Cognimeta Inc.+maintainer: Patrick Premont <ppremont@cognimeta.com>+homepage: https://github.com/Cognimeta/perdure+package-url:+bug-reports:+synopsis: Robust persistence for acyclic immutable data+description: +	     Perdure™, a Cognimeta product, aims to provide a simple and robust persistence mechanism for acyclic+	     immutable data with an easily comprehensible cost-model. It persists to raw block devices.+	     .+	     For some classes of applications, it can replace the use of traditional DMBS and keep the data modelled in+	     a manner that is natural for purely functional languages. It is not quite orthogonal persistence for+	     Haskell, which would automatically turn any non-persistent program into a persistent one, but it aims to+	     minimize the scope of changes required to make an application persistent.+	     . +	     The persistence process is strict, it does not persist thunks or closures, but only the fully evaluated+	     data, which must be acyclic. It also requires some changes to the data types and algorithms. References+	     must be inserted at some strategic places within data structures. These cut the structure into separately+	     loadable parts. These parts should hold at least a few hundred bytes to reduce the frequency of disk+	     reads. The application has control over the representation so it can optimize it in terms of the+	     anticipated access patterns. A SizeRef reference type is provided which separates automatically if its size+	     threshold is reached, and inlines the data otherwise. As a convenience, a Map type is also provided which+	     uses SizeRef on internal tree nodes. It can grow beyond the memory size and still remain efficient for+	     lookups and traversals. Other persistent data structures with similar properties can be built on top of+	     Perdure™.+	     .+	     For the user application, dereferencing is a pure computation. This is similar to lazy loading, but the+	     reference data types do not hold ordinary references to their referent, only their location. This allows+	     the referent to be unloaded transparently. Also since the reference holds the location and size of the data+	     on the storage medium, dereferencing is very simple and efficient. No index need to be accessed, we only+	     need to check a cache in case the data is already loaded.+	     .+	     Persisters for data types are created using safe combinators. Serialization is done at the bit level,+	     allowing for very compact representations.+	     . +	     Undetected corruption is virtually impossible even in the presence of drive failures. Each separately+	     loadable section has a 128-bit digest, and that digest is stored in the reference(s). This approach+	     alleviates the need for low-level storage replication such as RAID, and takes care of replication at the+	     persistence layer level. This seems appropriate given the increasing need for geographically distributed+	     replication.+	     .+	     Persistence occurs in discrete transactions. These run in the IO monad. Transactions may be requested by+	     multiple threads but they may block until they get their turn. Within a transaction, multiple threads or sparks+	     can be used to examine the current state and compute the next state to be persisted.+	     .+	     Reference counting is used to automatically reclaim unused storage.+	     .+	     Since persisted data is immutable, it is trivial for applications to keep some or all historical states by+	     using a list-like type as their root persisted type. Those past states can be used for analysis or possibly+	     to recover data lost because of an application-level error. The library includes a History data type which+	     automatically preserves a greater number of recent states and fewer older states.+	     .+	     We support 32bit, 64bit, little-endian and big-endian architectures. We allow platforms to write data and+	     generate digests in their native format for maximum speed, but they should be able to read the data written+	     by other platforms with the necessary conversions. Each reference stores the endianness and word size of the+	     referent representation so databases can be moved between platforms without any conversion, and they could+	     be read concurrently by different platforms.+	     .+	     A general mechanism 'Database.Perdure.Rev' is provided to upgrade the persisted types.+	     Its goal is similar to that of the safecopy package. Here however, the Rev module simply exports a type+	     that is similar to Either but whose persister leaves room in the representation to accommodate future+	     versions. We use it to create growing lists of alternatives such as User1.User :> User0.User :> NoRev.+	     This type should always be your root persisted type. You should also use it on the nested parts of+	     your data whose type is more subject to change: this will avoid having to propagate all type changes up+	     to the root.+	     .+	     This library is young and there remains limitations that will need to be addressed in future releases:+	     .+	     * Memory references are not tracked. At this point it is assumed that the current persisted state is the+	     only root for persistent GC purposes. So no reference must be kept to previous persisted states. This is+	     not enforced by the API so care is needed. Otherwise dereferencing a dangling reference might fail+	     (but will not return bad data thanks to the digest).+	     .+	     * Care is needed by the application developers to ensure they do not change type persisters. The persisters+	     themselves are not persisted so the library cannot verify that it is using the same persister as with+	     previous executions. There are two problems with persisting persisters: they are not acyclic, and they+	     refer to user specified bijections. We encourage you to treat types and persisters as immutable code. Put+	     each persisted type in a distinct file, such as User0.hs. When a revision is needed create User1.hs.+	     .+	     * The current allocation strategy is trivial. We must add a new node type in the free space representation+	     that will allow us to search efficiently for a block of sufficient size. We currently scan all free+	     intervals from the start. This relatively simple fix should be done shortly, but until it is done the library will+	     not be appropriate for databases beyond ~100MB.+	     .+	     * Reclamation of free space simply occurs after some fixed number of state writes.+	     .+	     * Replication is local only at the moment. We write to all replicas, and read from the first correct one. We+	     need to support remote storage which can become temporarily unavailable, and user controlled policies+	     regarding those occurrences. Note that quorum voting is not needed for replica control of most (non-root)+	     allocations because digests are contained in the references and we can detect when we are reading outdated+	     data.+	     .+	     * Only raw disks configured for write-through caching will guarantee atomicity. Any other setup introduces+	     more layers, such as file systems, which could lie about when data has actually been written out to+	     disk. Perhaps our view is too pessimistic, and with proper action by this library other storage types could+	     be supported. Currently file based storage is only supported for testing purposes and should not be used+	     for live databases.+	     .+	     * A directory of bad sectors with alternative locations will need to be added. It will only need to be looked-up+	     and updated for reads with incorrect digests.+	     .+	     * Sharing is not realized unless it happens in separate steps. During the writing of some state, a+	     reference creates an allocation. In subsequent states we can refer to that same reference in multiple+	     locations and sharing will occur. If a reference is shared in memory before being first written out, it+	     will be written out multiple times without sharing of the referent. In the future we may rely on+	     System.Mem.StableName to improve on that.+	     .+	     * Currently, references are local. We would like to be able to refer to the allocations of another thread or+	     process. This will be a more involved addition so it will require distributed garbage collection such as+	     weighted reference counting.+	     .+	     * Documentation and examples are not sufficient and should be our first focus. For a minimal example,+	     look at Database.Perdure.TestState.testStatesF in exe-src.+	     .+	     Given those limitations, Perdure™ is not applicable for very large scale projects at the moment. But it can+	     be ideal for smaller projects where there is no point in burdening the developer with a distinct data+	     model. It can also be used as a temporary solution before integrating to external databases.+	     .+	     Cognimeta's Iota Charts web application <https://iotacharts.com>, is based on Perdure™ and has been has+	     been live for close to a year. Its database is relatively small at ~80MB currently, but we have been very+	     pleased with the results.+	     .+	     Perdure™ has been developed by Cognimeta Inc. over the past two years. We are releasing this as open+	     source under the permissive Apache license 2.0. The persistence mechanism is relatively simple and concise+	     and its open source nature can provide the inquisitive user with added confidence about the security of its+	     data.  Also Cognimeta has been using Haskell exclusively, and has benefited from many+	     excellent open source libraries. We are happy to contribute back, and are hoping for constructive and+	     critical feedback from this very bright community.+category: Databases+author: Patrick Premont for Cognimeta Inc.+tested-with:+data-files:+data-dir: ""+extra-source-files:+extra-tmp-files:+ +library+  buildable: True+  hs-source-dirs: src+  if arch(i386)+    cpp-options: -DWORDSIZE=32+  if arch(x86_64)+    cpp-options: -DWORDSIZE=64+  extensions: CPP+  exposed-modules:+    Database.Perdure+    Database.Perdure.AllocCopy+    Database.Perdure.Allocator+    Database.Perdure.ArrayRef+    Database.Perdure.CDeserializer+    Database.Perdure.CRef+    Database.Perdure.CSerializer+    Database.Perdure.Count+    Database.Perdure.DRef+    Database.Perdure.Data.Map+    Database.Perdure.Data.MapMultiset+    Database.Perdure.Decrementer+    Database.Perdure.Deref+    Database.Perdure.History+    Database.Perdure.Incrementer+    Database.Perdure.LocalStoreFile+    Database.Perdure.Package+    Database.Perdure.Persistent+    Database.Perdure.RNF+    Database.Perdure.Ref+    Database.Perdure.ReplicatedFile+    Database.Perdure.Rev+    Database.Perdure.RootValidator+    Database.Perdure.SingleStoreFile+    Database.Perdure.SizeRef+    Database.Perdure.Space+    Database.Perdure.SpaceBook+    Database.Perdure.SpaceTree+    Database.Perdure.State+    Database.Perdure.StoreFile+    Database.Perdure.Validator+    Database.Perdure.WValidator+    Database.Perdure.WordArrayRef+    Database.Perdure.WordNArrayRef+    Database.Perdure.WriteBits+  other-modules:        +    Database.Perdure.Digest+  build-depends:+    base >= 4.5.0.0 && < 5,+    template-haskell >= 2.7.0.0,+    cognimeta-utils == 0.1.0,+    QuickCheck >=2.4.0.1,+    strict >= 0.3.2,+    mtl >= 2.1.2,+    transformers >= 0.3.0.0,+    filepath >= 1.3.0.0,+    containers >= 0.4.2.1,+    binary >= 0.5.1.0,+    collections-api >= 1.0.0.0,+    cryptohash == 0.7.2,+    -- ***** cryptohash >= 0.7.3 has updated Skein to version 1.3, so the upgrade would require full rebuilds of our databases+    bytestring >= 0.9.2.1,+    array >= 0.4.0.0,+    stm >= 2.3,+    ghc-prim >= 0.2.0.0,+    primitive >= 0.4.1,+    tagged >= 0.4.2.1,+    data-lens >= 2.9.0,+    data-lens-fd >= 2.0.2,+    data-lens-template >= 2.1.5,+    comonad-transformers >= 2.1.1.1,+    time >= 1.4.0.1,+    unix >= 2.5.1.0,+    data-binary-ieee754 >= 0.4.2.1,+    lrucache >= 1.1.1,+    deepseq >= 1.3.0.0,+    deepseq-th >= 0.1.0.3++  ghc-options: -rtsopts -fcontext-stack=80 -O2 -funfolding-use-threshold=24 -pgmP cpphs -optP --cpp+  extensions: ++source-repository head+  type:     git+  location: git://github.com/Cognimeta/perdure.git++executable perdure+  hs-source-dirs: exe-src+  main-is: Main.hs+  other-modules: +  build-depends:+    base >= 4.5.0.0,+    template-haskell >= 2.7.0.0,+    cognimeta-utils == 0.1.0,+    mtl >= 2.1.2,+    deepseq,+    QuickCheck >=2.4.0.1,+    perdure >= 0.1.0,+    transformers >= 0.3.0.0,+    bytestring >= 0.9.2.1,+    containers >= 0.4.2.1,+    MonadRandom == 0.1.3+  ghc-options: -rtsopts -fcontext-stack=80 -fno-warn-duplicate-exports -O2 -funfolding-use-threshold=24 -threaded
+ src/Database/Perdure.hs view
@@ -0,0 +1,74 @@+{-+Copyright 2010-2012 Cognimeta Inc.++Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at++     http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software distributed under the License is+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express+or implied. See the License for the specific language governing permissions and limitations under the License.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Database.Perdure(+  module Database.Perdure.Persistent,+  defaultRootLocation,+  newCachedFile,+  PVar,+  openPVar,+  createPVar,+  updatePVar,+  updateInspectPVar+  ) where++import Prelude()+import Cgm.Prelude+import Database.Perdure.State+import Database.Perdure.Persistent+import Cgm.Control.Monad.State as M+import Cgm.Data.Typeable+import Control.Monad hiding (sequence)+import Control.Monad.Trans+import Control.Monad.Reader hiding (sequence)+import Control.Applicative+import Cgm.Control.Concurrent.MVar+import Cgm.Data.Super+import Data.Word++-- | Wraps a ReplicatedFile with cache of a given size (number of dereferenced DRefs)+newCachedFile :: Integer -> ReplicatedFile -> IO CachedFile+newCachedFile sz f = CachedFile f <$> newMVar (emptyCache sz)++-- | At the moment this is the only way to create a rootLocation.+-- The root of the database will be located in one of two reserved locations at the start of the specified files.+defaultRootLocation :: CachedFile -> RootLocation+defaultRootLocation f = RootLocation f [RootAddress 0, RootAddress $ apply super rootAllocSize]++-- | Represents a persisted database. Contains a (ram-only) lock to sequence multithreaded operations,+-- so only one 'PVar' must be created per 'RootLocation'.+newtype PVar s = PVar (MVar (PState s))++-- | Creates a PVar with the specified initial state. Writes at the specified location, using the given maximum usable space (in bytes).+createPVar :: (Typeable s, Persistent s) => s -> Word64 -> RootLocation -> IO (PVar s)+createPVar s sz l = initState l (addSpan (sortedPair roots sz') emptySpace) s >>= fmap PVar . newMVar where+  roots = 2 * apply super (getLen rootAllocSize)+  sz' =+    if sz <= roots+    then error $ "createPVar needs a max size of at least " ++ show roots ++ " bytes"+    else getLen (coarsenLen (unsafeLen (sz - roots) :: Len Word8 Word64) :: Len Word64 Word64)++-- | Attempts to open a PVar by reading at the given 'RootLocation'. Do not open the same location multiple times, share+-- the PVar instead.+openPVar :: (Typeable s, Persistent s) => RootLocation -> IO (Maybe (PVar s))+openPVar l = readState l >>= sequence . fmap (fmap PVar . newMVar)++-- | Persist a state change+updatePVar :: (Typeable s, Persistent s) => PVar s -> M.StateT s IO a -> IO a+updatePVar (PVar v) t = stateTModifyMVar v $ toStandardState $ updateState t++-- | This function allows read access to the bookkeeping structures of the database. The 'PState' type is subject to change.+updateInspectPVar :: (Typeable s, Persistent s) => PVar s -> M.StateT s (ReaderT (PState s) IO) a -> IO a+updateInspectPVar (PVar v) t = stateTModifyMVar v $ toStandardState $ updateStateRead t
+ src/Database/Perdure/AllocCopy.hs view
@@ -0,0 +1,49 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Perdure.AllocCopy (
+  AllocCopy(..),
+  allocCopyBits,
+  module Database.Perdure.WriteBits
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Database.Perdure.WriteBits
+import Cgm.System.Endian
+
+class Endian w => AllocCopy w where
+  allocCopyBitsSkip :: (BitSrc d, SrcDestState d ~ RealWorld) => Len w Word -> d -> d -> ST RealWorld (STPrimArray RealWorld Pinned w)
+
+allocCopyBits :: (BitSrc d, SrcDestState d ~ RealWorld, AllocCopy w) => d -> d -> IO (PrimArray Pinned w)
+allocCopyBits start end = stToIO $ allocCopyBitsSkip 0 start end >>= unsafeFreezeSTPrimArray
+
+instance AllocCopy Word32 where
+  allocCopyBitsSkip skip start end = onWordConv
+                                     (apply wordConv1 <$> allocCopyBitsSkip (retract wordLenB skip) start end) 
+                                     (error "allocCopyBitsSkip for Word32 not implemented") 
+instance AllocCopy Word64 where
+  allocCopyBitsSkip skip start end = onWordConv
+                                     (error "allocCopyBitsSkip for Word64 not implemented") 
+                                     (apply wordConv1 <$> allocCopyBitsSkip (retract wordLenB skip) start end) 
+
+instance AllocCopy Word where
+  -- Starts writing after the specified length 'skip', which can later be used to write a header.
+  allocCopyBitsSkip skip start end = do
+    wBuf <- mkArray $ coarsenLen (addedBits end start) + skip
+    copyBits end start (aligned $ CWordSeq wBuf skip) >>= padIncompleteWord
+    return wBuf
+ src/Database/Perdure/Allocator.hs view
@@ -0,0 +1,44 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+
+module Database.Perdure.Allocator (
+  Allocator(..),
+  allocWrite,
+  module Database.Perdure.StoreFile,
+  module Database.Perdure.LocalStoreFile,
+  module Database.Perdure.SingleStoreFile,
+  module Database.Perdure.ReplicatedFile
+  ) where
+  
+import Prelude ()
+import Cgm.Prelude
+import Data.Word
+import Database.Perdure.StoreFile
+import Database.Perdure.LocalStoreFile
+import Database.Perdure.SingleStoreFile
+import Database.Perdure.ReplicatedFile
+import Cgm.Data.Len
+import Cgm.Data.Array
+import Cgm.Data.Super
+import Cgm.System.Endian
+  
+class Allocator l where 
+  alloc :: l -> Len Word64 Word64 -> IO (Len Word64 Word64) -- take required size, and returns the address
+  allocatorStoreFile :: l -> ReplicatedFile
+
+allocWrite :: (Allocator l, LgMultiple Word64 w, Endian w) => l -> Endianness -> [PrimArray Pinned w] -> IO (StoreRef ReplicatedFile w)
+allocWrite l e as = do
+    addr <- alloc l $ apply super (coarsenLen $ sum $ arrayLen <$> as :: Len Word64 Word)
+    storeFileWrite (allocatorStoreFile l) addr e as
+ src/Database/Perdure/ArrayRef.hs view
@@ -0,0 +1,28 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Perdure.ArrayRef (
+  ArrayRef(..),
+  module Database.Perdure.Allocator
+  ) where
+
+import Database.Perdure.Allocator
+
+class ArrayRef (r :: (* -> *) -> *) where
+  type ArrayRefElem r
+  writeArrayRef :: (Allocator l) => l -> PrimArray Pinned (ArrayRefElem r) -> IO (r (StoreRef ReplicatedFile))
+  derefArrayRef :: (StoreFile f, Allocation fr) => f -> r (StoreRef f) -> IO (Maybe (ArrayRange (PrimArray fr (ArrayRefElem r))))
+  arrayRefAddr ::  r BasicRef -> Len Word64 Word64
+
+ src/Database/Perdure/CDeserializer.hs view
@@ -0,0 +1,144 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeFamilies, RankNTypes, DeriveFunctor, FlexibleContexts, ScopedTypeVariables #-}
+
+module Database.Perdure.CDeserializer (
+  cDeser,
+  deserializeFromArray,
+  deserializeFromFullArray,
+  unsafeSeqDeserializer,
+  Deserializer(..),
+  Deserializable(..),
+  DeserOut(..),
+  module Database.Perdure.Persistent,
+  module Database.Perdure.CRef
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Data.Functor.Compose
+import Control.Concurrent
+import Database.Perdure.Persistent
+import Database.Perdure.CRef
+import Cgm.Data.Functor
+import Cgm.Data.Array
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Data.Bits
+import Foreign.Ptr
+import Database.Perdure.ReplicatedFile
+import System.IO.Unsafe
+
+-- TODO figure out why the Deserializer's Allocator df is free to differ from f. Why is it a type argument of Deserializer at all if it can be anything?
+
+-- TODO consider reimplementing as in CSerializer (no Serializer layer, and possibly with continuations) and check performance
+
+deserializeFromArray :: (Allocation f, Allocation df, Deserializable w) => Deserializer df a -> ArrayRange (PrimArray f w) -> DeserOut a
+deserializeFromArray d = (\(ArrayRange arr start _) -> deserialize d (refineLen start) arr) . deserInput
+
+deserializeFromFullArray :: forall f df w a. (Allocation f, Allocation df, Deserializable w, LgMultiple w Bool, Prim w) => 
+                            Deserializer df a -> ArrayRange (PrimArray f w) -> a
+deserializeFromFullArray d arr = case deserializeFromArray d arr of
+  DeserOut a end -> bool (error $ "Inconsistent deserialized size: " ++ show (end, refineLen $ arrayLen arr :: Len Bool Word)) a $ 
+             (coarsenLen end :: Len w Word) == arrayLen arr
+
+-- | The passed persister must have no references
+unsafeSeqDeserializer :: Persister a -> Deserializer Free a
+unsafeSeqDeserializer p = cDeser p (DeserializerContext (error "seqDeserializer has no file" :: ReplicatedFile) (error "seqDeserializer has no cache"))
+
+cDeser :: Persister a -> DeserializerContext -> Deserializer Free a
+cDeser p = case p of
+  PartialWordPersister n -> const $ partialWordDeserializer n
+  PairPersister pa pb -> liftA2 (liftA2 (,)) (cDeser pa) (cDeser pb)
+  EitherPersister pa pb -> \dc -> cDeser persister dc >>= bool (Left <$> cDeser pa dc) (Right <$> cDeser pb dc)
+  ViewPersister i pb -> flip functorIacomap i . cDeser pb
+  SummationPersister pi d _ -> \dc -> cDeser pi dc >>= d (\pb ba -> fmap ba $ cDeser pb dc)
+  DRefPersister' -> \dc -> DRef persister dc <$> cDeser persister dc 
+  CRefPersister' _ pra -> fmap Refed . cDeser pra
+  
+instance InjectionACofunctor (Deserializer f) where
+  {-# INLINE iacomap #-}
+  iacomap = functorIacomap
+
+bitDeserializer :: Deserializer f Word
+bitDeserializer = Deserializer $ \bit arr -> DeserOut (let (wIx, bIx) = coarseRem bit in (indexArray arr wIx `partialShiftRL` getLen bIx) .&. 1) (bit + 1)
+
+-- 0 <= n <= wordBits
+partialWordDeserializer :: Len Bool Word -> Deserializer f Word
+partialWordDeserializer n
+  | n == 0 = pure 0
+  | n == 1 = bitDeserializer
+  | otherwise =
+    Deserializer $ \bit arr -> 
+    DeserOut (
+      let (wIx, bIx) = coarseRem bit 
+          avail = wordBits - bIx
+          overflow = n - avail
+          n' = wordBits - n
+      in bool (indexArray arr wIx `partialShiftL` getLen (n' - bIx) `partialShiftRL` getLen n') 
+         ((indexArray arr wIx `partialShiftRL` getLen bIx) + (indexArray arr (wIx + 1) `partialShiftL` getLen (wordBits - overflow) `partialShiftRL` getLen n')) $ 
+         (signed $* getLen overflow) > 0)
+    (bit + n)
+
+---------------------------------------------------------------------------
+
+class Deserializable a where deserInput :: (Allocation f, Allocation f') => ArrayRange (PrimArray f a) -> ArrayRange (PrimArray f' Word)
+  
+instance Deserializable Word where deserInput = primArrayMatchAllocation
+instance Deserializable Word32 where
+  deserInput a = onWordConv
+                 (primArrayMatchAllocation $ retract wordConvArrayRange a) 
+                 (fullArrayRange $ mkArrayWith (coarsenLen $ arrayLen a) $ 
+                        (\i -> retract wordConv $ retract splitWord64LE 
+                               (indexArray a i, if i + 1 < arrayLen a then indexArray a (i + 1) else 0)) . refineLen) -- TODO: test
+instance Deserializable Word64 where
+  deserInput a = onWordConv
+                 (fullArrayRange $ mkArrayWith (refineLen $ arrayLen a) $ 
+                        (\(i, r) -> retract wordConv $ bool fst snd (r == 0) $ apply splitWord64LE $ indexArray a i) . coarseRem) -- TODO test
+                 (primArrayMatchAllocation $ retract wordConvArrayRange a) 
+
+---------------------------------------------------------------------------
+
+-- Deserialization is strict so once DeserOut is forced, we no longer retain the input array. 
+-- The strict annotation in DeserOut is not quite sufficient to enfoce that, we also have to make sure we do not put in
+-- there a structure with interal thunks pointing to the array. But inspecting this file should show no such Deserializer.
+data DeserOut a = DeserOut {
+  deserValue :: !a,
+  deserPos :: {-# UNPACK #-} !(Len Bool Word)} deriving Functor
+
+-- If deserialization was lazy, the lifetime of the array would be unpredictable, so to avoid fragmentation of pinned arrays, we would prefer f = Free
+-- But now deserialization is strict and the array is not retained so either Free or Pinned will do.
+newtype Deserializer f a = Deserializer {deserialize :: Len Bool Word -> PrimArray f Word -> DeserOut a}
+instance Functor (Deserializer f) where
+  {-# INLINE fmap #-}
+  fmap g = Deserializer . ((fmap g <$>) <$>) . deserialize
+--instance Pointed (Deserializer c) where
+--    point x = ... inlined into pure
+instance Applicative (Deserializer f) where
+  {-# INLINE pure #-}
+  pure x = Deserializer $ \bit _ -> DeserOut x bit
+  {-# INLINE (<*>) #-}
+  g <*> x = Deserializer $ \bit ptr -> case deserialize g bit ptr of DeserOut g' bit' -> deserialize (g' <$> x) bit' ptr
+    -- we could define <*> = ap, but we would like to see if we could use <*> in the definition of join instead, see reflexion below
+instance Monad (Deserializer f) where
+  {-# INLINE return #-}
+  return = pure
+  {-# INLINE (>>=) #-}
+  (>>=) = fmap join . flip fmap where
+    {-# INLINE join #-}
+    join :: Deserializer f (Deserializer f a) -> Deserializer f a
+    join d2 = Deserializer $ \bit ptr -> case deserialize d2 bit ptr of DeserOut d bit' -> deserialize d bit' ptr
+
+getBitDeserializer :: Deserializer f (Len Bool Word)
+getBitDeserializer = Deserializer $ \bit _ -> DeserOut bit bit
+ src/Database/Perdure/CRef.hs view
@@ -0,0 +1,37 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE FlexibleContexts, TupleSections, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-}
+
+module Database.Perdure.CRef (
+  CRef(..),
+  onCRef
+  ) where
+
+import Control.Concurrent
+import Control.Applicative
+import System.IO.Unsafe
+import Cgm.Control.Combinators
+import Data.Dynamic
+import Cgm.Data.Typeable
+import Database.Perdure.Package
+
+
+data CRef r a = Refed !(r a) | ToRef !a
+instance (Typeable1 r, Typeable a) => Typeable (CRef r a) where 
+  typeOf _ = mkTyCon3 perdurePackage "Database.Perdure.CRef" "CRef" `mkTyConApp` [typeOf1 (undefined :: r ()), typeOf (undefined :: a)]
+                                                                                                                                                                    
+
+{-# INLINE onCRef #-}
+onCRef :: (r a -> b) -> (a -> b) -> CRef r a -> b
+onCRef refed toRef st = case st of {Refed ss -> refed ss; ToRef a -> toRef a}
+ src/Database/Perdure/CSerializer.hs view
@@ -0,0 +1,146 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, RankNTypes, FlexibleInstances, TupleSections, ScopedTypeVariables, MagicHash, UnboxedTuples, BangPatterns, GADTs #-}
+
+module Database.Perdure.CSerializer (
+  SerializerContext,
+  cSer,
+  serializeToArray,
+  Address,
+  module Database.Perdure.CDeserializer,
+  module Cgm.Control.Concurrent.NotificationCount
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+
+import Data.Functor.Compose
+import Control.Concurrent
+import Control.Monad.State
+import GHC.Base hiding ((.), id)
+import GHC.IO hiding (liftIO)
+import GHC.Exts
+import Cgm.Data.Functor.Sum
+import Cgm.Data.Either
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Cgm.Control.Concurrent.NotificationCount
+import Cgm.Control.Combinators
+import Database.Perdure.CDeserializer
+import Database.Perdure.Count
+import Cgm.Data.Multiset as MS
+import Data.IORef
+import System.IO.Unsafe
+import Database.Perdure.AllocCopy
+import Foreign.Ptr
+import Cgm.Data.Maybe
+import Database.Perdure.ReplicatedFile
+import Database.Perdure.Allocator
+import Database.Perdure.ArrayRef
+import Database.Perdure.WordArrayRef
+import Database.Perdure.WordNArrayRef
+import Database.Perdure.Persistent
+import Cgm.Data.MapMultiset
+import qualified Data.Cache.LRU as LRU
+import Data.Dynamic
+import Debug.Trace
+
+
+-- Important : We must not read (deref) a ref that has just been written in the current writeState.
+-- Since reodering of operations is allowed except across the storeFileFullBarrier (performed at the end of
+-- write State), this ensures that we do not read data which has not yet been fully written.
+
+-- TODO make sure just written ref's can be inserted in the cache, since that data is likely to be accessed again
+
+type CountDest c = Maybe (MVar (c Address))
+addCount :: Multiset c => Address -> CountDest c -> IO ()
+addCount a = maybe (return ()) $ flip modifyMVar_ $ return . MS.insert a
+type SerializerContext l c = (MVar Cache, l, CountDest c) -- TODO create type with strict fields
+
+-- TODO: consider testing whether returning a CSer (Maybe a) might be more performant, where Nothing represent the input a
+
+type Dest = ABitSeq RealWorld
+
+cSer :: (Multiset c, Allocator l) => Persister a -> SerializerContext l c -> (a -> Dest -> IO z) -> a -> Dest -> IO z
+cSer !p !sc !k !a !d = case p of
+  PartialWordPersister n
+    | n == wordBits -> stToIO (addWord a d) >>= k a
+    | n == 0 -> k a d
+    | otherwise -> stToIO (addBits n a d) >>= k a 
+  PairPersister pb pc -> case a of (b, c) -> cSer pb sc (\b' -> cSer pc sc (\c' -> k (b', c')) c) b d
+  EitherPersister pb pc -> either (\b -> stToIO (addBit 0 d) >>= cSer pb sc (k . Left) b) (\c -> stToIO (addBit 1 d) >>= cSer pc sc (k . Right) c) a
+  ViewPersister i pb -> cSer pb sc (k . fromJust . unapply i) (apply i a) d
+  SummationPersister pi _ s -> s (\i pb ba b -> cSer pi sc (const $ cSer pb sc (k . ba) b) i d) a -- i' is ignored, i type should not contain CRefs
+  DRefPersister' -> case a of (DRef _ _ w) -> 
+                                case sc of (_, _, c) -> addCount (arrayRefAddr w) c >> 
+                                                        cSer persister sc (const $ k a) w d -- TODO verify if call to persister is wastful
+  CRefPersister' rp prb -> onCRef (\rb -> cSer prb sc (const $ k a) rb d) (\b -> cSerRef rp sc (k . Refed) b d) a  
+
+-- Creates the ref and serializes it
+cSerRef :: (Multiset c, Allocator l, Persistent a, Typeable a) => RefPersister r -> SerializerContext l c -> (r a -> Dest -> IO z) -> a -> Dest -> IO z
+cSerRef !rp !sc !k !a !d = case rp of
+  Ref0Persister -> cSer persister sc (k . Ref0) a d
+  RefView rbra pb -> cSerRef pb sc (k . rbra) a d
+  SizeRefPersister maxSize -> 
+    let p = persister  -- TODO verify if call to persister is wastful
+        start = d
+        asDRef (Ref0 a') dStart dEnd = do
+          --readIORef writeCount >>= putStr . (++ ",") . show
+          --readIORef writeCount >>= writeIORef writeCount . (+ 1)
+          --empty <- stToIO $ mkABitSeq
+          --putStrLn $ ("CSerializer: Popped size = " ++) $ showLen $ addedBits dEnd dStart
+          --putStrLn $ ("CSerializer: Stack size = " ++) $ showLen $ addedBits dStart empty
+          dRef <- mkDRef sc p (Just a') dStart dEnd
+          afterTrue <- stToIO $ addBit 1 start
+          cSer DRefPersister' (noCount sc) (k . Sum . Right) dRef afterTrue -- Doesn't pass CountDest. We don't count first references.
+    in 
+     stToIO (addBit 0 start) >>= \afterFalse -> 
+     cSerRef Ref0Persister sc 
+     (\r0 end0 -> bool (k (Sum $ Left r0) end0) (asDRef r0 afterFalse end0) (addedBits end0 afterFalse > maxSize)) a afterFalse
+  CRefPersister _ -> error "CRef of CRef not yet implemented" -- TODO write
+  DRefPersister -> 
+    let p = persister in -- TODO verify if call to persister is wastful
+    stToIO mkABitSeq >>= \start -> cSer p sc (\a' end -> mkDRef sc p (Just a') start end >>= \dRef -> cSer DRefPersister' (noCount sc) k dRef d) a start
+        -- Doesn't pass CountDest. We don't count first references.q
+        -- TODO optimization : if the WordSeq fits in a single chunk, we should be able to writeDRef directly from it, since it is already aligned
+  IRefPersister pb -> cSerRef pb sc (k . IRef) a d
+  
+noCount :: SerializerContext l c -> SerializerContext l c
+noCount (cache, l, c) = (cache, l, Nothing)
+
+mkDRef :: (Allocator l, BitSrc s, SrcDestState s ~ RealWorld, Typeable a) => 
+          SerializerContext l c -> Persister a -> Maybe a -> s -> s -> IO (DRef a)
+mkDRef sc@(cache, l, _) p ma = writeDRef p ma (DeserializerContext (allocatorStoreFile l) cache) l
+
+writeDRef :: (Allocator l, BitSrc s, SrcDestState s ~ RealWorld, Typeable a) => 
+             Persister a -> Maybe a -> DeserializerContext -> l -> s -> s -> IO (DRef a)
+writeDRef p ma dc@(DeserializerContext _ c) l start end = 
+  DRef p dc <$> maybe id (\a -> (>>= \w -> w <$ addToCache a w)) ma (allocCopyBits start end >>= writeArrayRef l) where
+  addToCache a w = let addr = arrayRefAddr w in modifyMVar_ c $ 
+                                                return . {-(trace ("writing/adding to cache at" ++ show addr) $ -}LRU.insert addr (toDyn a)
+  
+-- | The passed Persister must hace no references
+{-# NOINLINE serializeToArray #-}
+serializeToArray :: AllocCopy w => Persister a -> a -> PrimArray Pinned w
+serializeToArray p a = unsafePerformIO $ do
+  start <- stToIO mkABitSeq 
+  noCache <- newMVar $ LRU.fromList Nothing []
+  cSer p (noCache, NoAllocator, Nothing :: CountDest MapMultiset) (const $ allocCopyBits start) a start
+                             
+data NoAllocator = NoAllocator
+instance Allocator NoAllocator where
+  alloc = error "NoAllocator"
+  allocatorStoreFile = error "NoAllocator"
+    
+
+ src/Database/Perdure/Count.hs view
@@ -0,0 +1,23 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+module Database.Perdure.Count (
+  Address
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Data.Word
+import Cgm.Data.Len
+
+type Address = Len Word64 Word64
+ src/Database/Perdure/DRef.hs view
@@ -0,0 +1,25 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+module Database.Perdure.DRef (
+  module Database.Perdure.Deref,
+  module Database.Perdure.StoreFile,
+  module Database.Perdure.WordArrayRef,
+  module Database.Perdure.WordNArrayRef
+  ) where
+
+import Database.Perdure.WordArrayRef
+import Database.Perdure.WordNArrayRef
+import Database.Perdure.Deref
+import Database.Perdure.StoreFile
+
+ src/Database/Perdure/Data/Map.hs view
@@ -0,0 +1,308 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE DeriveFunctor, ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, KindSignatures, TypeFamilies, FlexibleContexts #-}
+
+module Database.Perdure.Data.Map(
+  Map,
+  updateM,
+  empty,
+  null,
+  lookup,
+  insert,
+  insertWith,
+  delete,
+  foldlWithKey,
+  foldrWithKey,
+  fromList,
+  toList,
+  assocs,
+  elems,
+  maxKey,
+  scan,
+  Database.Perdure.Data.Map.mapLens
+  ) where
+
+import Prelude hiding (null, lookup)
+import Cgm.Control.Monad.State
+import Database.Perdure.Persistent
+import Database.Perdure.SizeRef
+import Control.Arrow
+import Control.Monad
+import Data.Tuple
+import Data.Functor
+import Data.List(foldl')
+import Data.Lens
+import Cgm.Data.Nat
+import Database.Perdure.Ref
+import Cgm.Data.Maybe
+import Control.Comonad.Trans.Store
+import Data.Dynamic
+import Database.Perdure.Package
+import Cgm.Data.Typeable
+
+type R = CRef (SizeRef D9)
+
+moduleName :: String
+moduleName = "Database.Perdure.Data.Map"
+
+-- | Unlike Data.Map, this Map does not support constant time size computation
+data Map k a = Empty | NonEmpty !(Tree Leaf k a) deriving (Functor, Typeable)
+instance (Show k, Show a) => Show (Map k a) where show = show . toList
+
+newtype Reference t k a = Reference (R (t k a)) deriving Functor
+instance Typeable2 t => Typeable2 (Reference t) where 
+  typeOf2 _ = mkTyCon3 perdurePackage moduleName "Reference" `mkTyConApp` [typeOf2 (undefined :: t () ())]
+dereference :: Reference t k a -> t k a
+dereference (Reference t) = deref t
+reference :: t k a -> Reference t k a
+reference = Reference . ref
+newtype Leaf k a = Leaf a deriving (Functor, Typeable) -- TODO consider using data would allow's map's values to be thunks, as in Data.Map
+data Empt k a = Empt
+
+data Tree t k a = LastLevel !(Upper t k a) | NextLevel !(Tree (Reference (Node t)) k a) deriving (Functor)
+
+-- The k's are the maximum elements of the preceeding 'c'. The maximum element of the last 'c' is not stored but is passed from the context.
+data Node t k a = 
+  Node2 {-# UNPACK #-} !(Upper t k a) !(t k a) | 
+  Node3 {-# UNPACK #-} !(Upper t k a) {-# UNPACK #-} !(Upper t k a) !(t k a) deriving (Functor)
+instance Typeable2 t => Typeable2 (Node t) where 
+  typeOf2 _ = mkTyCon3 perdurePackage moduleName "Node" `mkTyConApp` [typeOf2 (undefined :: t () ())]
+
+data Upper t k a = Upper !k !(t k a) deriving (Functor) -- The k is the largest key in (t k a)
+mapUpper :: (ta k a -> tb k b) -> Upper ta k a -> Upper tb k b
+mapUpper f (Upper k tka) = Upper k $ f tka
+within :: Ord k => Upper t k a -> k -> Bool
+within (Upper k0 _) k = k <= k0
+
+node2 :: Upper t k a -> Upper t k a -> Upper (Node t) k a
+node2 uc0 (Upper u1 c1) = Upper u1 $ Node2 uc0 c1
+node3 :: Upper t k a -> Upper t k a -> Upper t k a -> Upper (Node t) k a
+node3 uc0 uc1 (Upper u2 c2) = Upper u2 $ Node3 uc0 uc1 c2
+onNode :: (Upper t k a -> Upper t k a -> z) -> (Upper t k a -> Upper t k a -> Upper t k a -> z) -> Upper (Node t) k a -> z
+onNode z2 z3 (Upper u n) = case n of
+  Node2 uc0 c1 -> z2 uc0 $ Upper u c1
+  Node3 uc0 uc1 c2 -> z3 uc0 uc1 $ Upper u c2
+
+data Out g c =
+  Merge g |
+  Single c |
+  Split c c
+
+appState :: Monad m => a -> (a -> b) -> StateT a m z -> StateT b m z
+appState a ab = viewState (const a, ab)
+
+-- | General update/lookup at a single key. The State monad used supports
+-- non-modification. Nothing denotes the absence of a value.
+updateM :: forall k a b. Ord k => k -> State (Maybe a) b -> State (Map k a) b
+updateM k s = get >>= \p -> case p of
+  Empty -> appState Nothing (maybe Empty $ NonEmpty . LastLevel . Upper k . Leaf) s
+  r@(NonEmpty t) -> (\(c, b) -> onModify (return b) ((b <$) . put) c) $ case t of
+    LastLevel ua -> first (fmap $ either NonEmpty (\Empt -> Empty)) $ trans' k s ua
+    NextLevel t -> first (fmap $ NonEmpty . either NextLevel id) $ updateT t where
+      updateT :: Tr t => Tree (Reference (Node t)) k a -> (Modify (Either (Tree (Reference (Node t)) k a) (Tree t k a)), b)
+      updateT (LastLevel ua) = first (fmap $ either Left (Right . LastLevel)) $ trans' k s ua
+      updateT (NextLevel t) = first (fmap $ Left . either NextLevel id) $ updateT t
+    
+trans' :: (Tr t, Ord k) => k -> State (Maybe a) b -> Upper t k a -> (Modify (Either (Tree t k a) (G t k a)), b)
+trans' k s a = first (fmap $ \o -> case o of 
+                  Merge a -> Right a
+                  Single a -> Left $ LastLevel a
+                  Split a0 a1 -> Left $ NextLevel $ LastLevel $ mapUpper reference $ node2 a0 a1
+              ) $ trans k s a
+
+data Modify a = Leave | Change !a deriving Functor
+onModify :: z -> (a -> z) -> Modify a -> z
+onModify l _ Leave = l
+onModify _ c (Change a) = c a
+
+class Tr (t :: * -> * -> *) where
+  type G t :: * -> * -> *
+  trans :: Ord k => k -> State (Maybe a) b -> Upper t k a -> (Modify (Out (G t k a) (Upper t k a)), b)
+  mergeLeft :: G t k a -> Upper t k a -> Either (Upper t k a) (Upper t k a, Upper t k a)
+  mergeRight :: Upper t k a -> G t k a -> Either (Upper t k a) (Upper t k a, Upper t k a)
+  foldlK :: (z -> k -> a -> z) -> z -> Upper t k a -> z
+  foldrK :: (k -> a -> z -> z) -> z -> Upper t k a -> z
+instance Tr Leaf where
+  type G Leaf = Empt
+  trans k f a@(Upper k0 (Leaf v0)) = 
+    if k == k0
+    then first (maybe Leave $ Change . maybe (Merge Empt) (Single . Upper k0 . Leaf)) $ swap $ runState f (Just v0)
+    else first (maybe Leave $ maybe Leave $ \v -> Change $ (if k > k0 then id else flip) Split a (Upper k $ Leaf v)) $ swap $ runState f Nothing
+  mergeLeft Empt = Left
+  mergeRight ua Empt = Left ua
+  foldlK f z (Upper k (Leaf a)) = f z k a
+  foldrK f z (Upper k (Leaf a)) = f k a z
+instance Tr t => Tr (Reference t) where
+  type G (Reference t) = G t
+  trans k f = first (fmap $ \o -> case o of
+                        Merge a -> Merge a
+                        Single a -> Single $ mapUpper reference a
+                        Split a0 a1 -> Split (mapUpper reference a0) (mapUpper reference a1)
+                    ) . trans k f . mapUpper dereference
+  mergeLeft g = (mapUpper reference +++ mapUpper reference *** mapUpper reference) . mergeLeft g . mapUpper dereference
+  mergeRight a g = (mapUpper reference +++ mapUpper reference *** mapUpper reference) $ flip mergeRight g $ mapUpper dereference a
+  foldlK f z = foldlK f z . mapUpper dereference
+  foldrK f z = foldrK f z . mapUpper dereference
+instance Tr t => Tr (Node t) where
+  type G (Node t) = Upper t
+  trans k f = onNode
+            (\c0 c1 -> if within c0 k
+                       then first (fmap $ \v -> case v of
+                                      Merge l -> either Merge (Single . uncurry node2) $ mergeLeft l c1
+                                      Single c0' -> Single $ node2 c0' c1
+                                      Split c00 c01 -> Single $ node3 c00 c01 c1
+                                  ) $ trans k f c0
+                       else first (fmap $ \v -> case v of
+                                      Merge l -> either Merge (Single . uncurry node2) $ mergeRight c0 l
+                                      Single c1' -> Single $ node2 c0 c1'
+                                      Split c10 c11 -> Single $ node3 c0 c10 c11
+                                  ) $ trans k f c1
+              )
+            (\c0 c1 c2 -> if within c0 k
+                          then first (fmap $ \v -> case v of
+                                      Merge l -> Single $ either (`node2` c2) (\(c0', c1') -> node3 c0' c1' c2) $ mergeLeft l c1
+                                      Single c0' -> Single $ node3 c0' c1 c2
+                                      Split c00 c01 -> Split (node2 c00 c01) (node2 c1 c2)
+                                  ) $ trans k f c0
+                          else if within c1 k
+                               then first (fmap $ \v -> case v of
+                                              Merge l -> Single $ either (node2 c0) (uncurry $ node3 c0) $ mergeLeft l c2
+                                              Single c1' -> Single $ node3 c0 c1' c2
+                                              Split c10 c11 -> Split (node2 c0 c10) (node2 c11 c2)
+                                          ) $ trans k f c1
+                               else first (fmap $ \v -> case v of
+                                              Merge l -> Single $ either (node2 c0) (uncurry $ node3 c0) $ mergeRight c1 l
+                                              Single c2' -> Single $ node3 c0 c1 c2'
+                                              Split c20 c21 -> Split (node2 c0 c1) (node2 c20 c21)
+                                          ) $ trans k f c2)
+  mergeLeft c = onNode
+                (\c0 c1 -> Left $ node3 c c0 c1) 
+                (\c0 c1 c2 -> Right (node2 c c0, node2 c1 c2))
+  mergeRight n c = ($ n) $ onNode
+                (\c0 c1 -> Left $ node3 c0 c1 c) 
+                (\c0 c1 c2 -> Right (node2 c0 c1, node2 c2 c))
+  foldlK f z  = onNode (\n0 n1 -> foldlK f (foldlK f z n0) n1) (\n0 n1 n2-> foldlK f (foldlK f (foldlK f z n0) n1) n2)
+  foldrK f z  = onNode (\n0 n1 -> foldrK f (foldrK f z n1) n0) (\n0 n1 n2-> foldrK f (foldrK f (foldrK f z n2) n1) n0)
+
+-- Here we implemented the function without creating Tr methods. Perhaps we should have done the same for foldlK, foldrK.
+-- We could even define them in terms of scan now.  
+scan :: forall k a z. (k -> a -> z) -> (k -> z -> z -> z) -> Map k a -> Maybe z
+scan kaz kzzz m = case m of 
+  Empty -> Nothing  
+  NonEmpty tr -> Just $ s1 tr $ \(Upper k (Leaf a)) -> kaz k a where
+    s1 :: Tree t k a -> (Upper t k a -> z) -> z
+    s1 tr utz = case tr of
+      LastLevel ut -> utz ut
+      NextLevel tr' -> s1 tr' $ \ut -> onNode 
+                                       (\u0@(Upper k0 _) u1 -> kzzz k0 (utz u0) (utz u1)) 
+                                       (\u0@(Upper k0 _) u1@(Upper k1 _) u2 -> kzzz k0 (utz u0) $ kzzz k1 (utz u1) (utz u2)) $ 
+                                       mapUpper dereference ut
+
+empty :: Map k a
+empty = Empty
+
+null :: Map k a -> Bool
+null Empty = True
+null _ = False
+
+lookup :: Ord k => k -> Map k a -> Maybe a
+lookup k = fst . runState (updateM k get)
+
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert k a m = fromMaybe m $ snd $ runState (updateM k $ put $ Just a) m
+
+insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWith f k a m = fromMaybe m $ snd $ runState (updateM k $ get >>= put . Just . maybe a (f a)) m
+
+delete :: Ord k => k -> Map k a -> Map k a
+delete k m = fromMaybe m $ snd $ runState (updateM k $ get >>= maybe (return ()) (const $ put Nothing)) m
+
+foldlWithKey :: forall z k a. (z -> k -> a -> z) -> z -> Map k a -> z
+foldlWithKey f z m = case m of
+  Empty -> z
+  NonEmpty t -> foldlf z t where
+    foldlf :: Tr t => z -> Tree t k a -> z
+    foldlf z (LastLevel t) = foldlK f z t
+    foldlf z (NextLevel t) = foldlf z t
+
+foldrWithKey :: forall z k a. (k -> a -> z -> z) -> z -> Map k a -> z
+foldrWithKey f z m = case m of
+  Empty -> z
+  NonEmpty t -> foldrf z t where
+    foldrf :: Tr t => z -> Tree t k a -> z
+    foldrf z (LastLevel t) = foldrK f z t
+    foldrf z (NextLevel t) = foldrf z t
+
+fromList :: Ord k => [(k, a)] -> Map k a
+fromList = foldl' (\z (k, a) -> insert k a z) empty
+
+toList :: Map k a -> [(k ,a)]
+toList = assocs
+
+assocs :: Map k a -> [(k ,a)]
+assocs = foldrWithKey (\k a l -> (k, a) : l) []
+
+elems :: Map k a -> [a]
+elems = fmap snd . assocs
+
+mapLens :: Ord k => k -> Lens (Map k a) (Maybe a)
+mapLens k = Lens $ \m -> store (\mv -> case mv of
+    Nothing -> delete k m
+    Just v' -> insert k v' m
+  ) (lookup k m)
+
+instance (Eq k, Eq a) => Eq (Map k a) where
+  a == b = toList a == toList b
+
+maxKey :: Map k a -> Maybe k
+maxKey Empty = Nothing
+maxKey (NonEmpty t) = Just $ maxKeyT t where
+  maxKeyT :: Tree t k a -> k
+  maxKeyT (NextLevel t) = maxKeyT t
+  maxKeyT (LastLevel (Upper k _)) = k
+
+
+{-
+
+data Map k a = Empty | NonEmpty (Tree k (Leaf k a))
+
+-- A balanced non-empty tree. There is an arbitrary number or Node nestings, but after ever 4 a CDRef wraps the tree.
+-- This means we get nodes in persistent storage that have between 2^4=16 and 3^4=81 children (perhaps on average 2*3*2*3 = 36).
+-- A random tree of 10^6 elements would mean 3.86 such persistent storage levels (we simplify by just assming that the probability
+-- of Node2 and Node3 is equal).
+-- The user can use Tree k a, or Tree k (CDRef a) depending on the size of a.
+-- Note that a 10 level tree would be represented as L4 (... L4 (... L2 (... ))), yet the L2 represents the top most, or outer, layers
+data Tree k c = 
+  L0 !(Upper k c) | 
+  L1 !(Upper k (Node k c)) | 
+  L2 !(Upper k (Node k (Node k c))) | 
+  L3 !(Upper k (Node k (Node k (Node k c)))) |
+  L4 !(Tree k (CDRef (Node k (Node k (Node k (Node k c))))))
+
+
+-}
+
+instance (Persistent a, Persistent k, Typeable k, Typeable a) => Persistent (Map k a) where persister = structureMap persister
+instance (Persistent k, Persistent (t k a), Typeable2 t, Typeable k, Typeable a) => Persistent (Tree t k a) where persister = structureMap persister
+instance Persistent a => Persistent (Leaf k a) where persister = structureMap persister
+instance (Persistent k, Persistent (t k a)) => Persistent (Node t k a) where persister = structureMap persister
+instance (Persistent (t k a), Typeable (t k a)) => Persistent (Reference t k a) where persister = structureMap persister
+instance (Persistent k, Persistent (t k a)) => Persistent (Upper t k a) where persister = structureMap persister
+
+deriveStructured ''Map
+deriveStructured ''Tree
+deriveStructured ''Leaf
+deriveStructured ''Node
+deriveStructured ''Reference
+deriveStructured ''Upper
+ src/Database/Perdure/Data/MapMultiset.hs view
@@ -0,0 +1,44 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, TemplateHaskell, DeriveDataTypeable #-}
+
+module Database.Perdure.Data.MapMultiset(
+  MapMultiset(mapMultisetMap),
+  module Cgm.Data.Multiset
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Cgm.Data.Maybe
+import Cgm.Data.Multiset
+import Database.Perdure.Persistent
+import Cgm.Control.Monad.State
+import Database.Perdure.Data.Map(Map)
+import qualified Database.Perdure.Data.Map as Map
+import Data.Dynamic
+import Cgm.Data.Typeable
+import Database.Perdure.Package
+
+newtype MapMultiset a = MapMultiset {mapMultisetMap :: Map a Integer} deriving Typeable
+
+instance Multiset MapMultiset where
+  emptySet = MapMultiset Map.empty
+  insert e (MapMultiset a) = MapMultiset $ Map.insertWith (+) e 1 a -- TODO implement and use insertWith' (strict application of combining function)
+  delete e (MapMultiset a) = fmap MapMultiset $ snd $ flip runState a $ Map.updateM e $ 
+                             get >>= maybe (return ()) (\c -> if c == 1 then put Nothing else put $ Just $ c - 1)
+
+instance (Typeable a, Persistent a) => Persistent (MapMultiset a) where persister = structureMap persister
+                                                                        
+deriveStructured ''MapMultiset
+
+ src/Database/Perdure/Decrementer.hs view
@@ -0,0 +1,62 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, Rank2Types, FlexibleContexts, ScopedTypeVariables, BangPatterns, GADTs #-}
+
+module Database.Perdure.Decrementer (
+  decr
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Structured
+import Control.Monad.State
+import Database.Perdure.Persistent
+import Database.Perdure.Space
+import Database.Perdure.Count
+import Database.Perdure.CSerializer(Address)
+import Cgm.Data.Monoid
+import Cgm.Data.Multiset as MS
+import Database.Perdure.SpaceBook
+import Database.Perdure.Ref
+import qualified Data.Cache.LRU as LRU
+import Data.Dynamic
+import Database.Perdure.ArrayRef
+import Control.Concurrent.MVar
+import System.IO.Unsafe
+import Debug.Trace
+
+-- TODO consider addding a (lazy) bool into persisters that says if StoreRefs are present in descendents, and checking it to prune parts of the traversal
+
+-- | Has effects through unsafePerformIO on the caches stored in the DRefs (removes any cache entries for the deallocated allocations).
+decr :: Persister a -> a -> SpaceBook -> SpaceBook
+decr !p !a !s = case p of
+  PartialWordPersister n -> s
+  PairPersister pb pc -> case a of (b, c) -> decr pc c $ decr pb b s
+  EitherPersister pb pc -> either (decr pb) (decr pc) a s
+  ViewPersister i pb -> decr pb (apply i a) s
+  SummationPersister pi _ f -> f (\i pb _ b -> decr pb b $ decr pi i s) a
+  DRefPersister' -> case a of (DRef _ (DeserializerContext _ cache) warr) -> 
+                                let referenced = decr persister $ let da = deref a in da `seq` unsafeClearCache cache (arrayRefAddr warr) `seq` da
+                                in either (\(WordNArrayRef _ r _) -> decrRef r referenced) (\(WordNArrayRef _ r _) -> decrRef r referenced) (unwrap warr) s
+  CRefPersister' _ pra -> onCRef (decr pra) (decr persister) a s
+
+{-# NOINLINE unsafeClearCache #-}
+unsafeClearCache :: MVar Cache -> Len Word64 Word64 -> ()
+unsafeClearCache c addr = unsafePerformIO $ modifyMVar_  c $ return . fst . LRU.delete addr
+
+decrRef :: forall w. LgMultiple Word64 w => 
+           BasicRef w -> (SpaceBook -> SpaceBook) -> SpaceBook -> SpaceBook
+decrRef r onDealloc sb@(SpaceBook c s) =
+  maybe ((\(SpaceBook c s') -> SpaceBook c ({-trace ("freeing span " ++ show (refSpan r)) $-} addSpan (refSpan r) s')) $ onDealloc sb)
+  (flip SpaceBook s) $ MS.delete (refStart r) c
+ src/Database/Perdure/Deref.hs view
@@ -0,0 +1,74 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE GADTs #-}
+
+
+module Database.Perdure.Deref (
+  Deref(..),
+  deref,
+  derefEq
+  ) where
+
+import System.IO.Unsafe
+import Cgm.Data.Functor.Sum
+import Cgm.Data.Maybe
+import Cgm.Control.Combinators
+import Database.Perdure.Persistent
+import Database.Perdure.CDeserializer
+import Database.Perdure.WordArrayRef
+import Database.Perdure.WordNArrayRef
+import Control.Applicative
+import Data.Word
+import Control.Concurrent.MVar
+import Control.Exception.Base
+import qualified Data.Cache.LRU as LRU
+import Data.Dynamic
+import Debug.Trace
+
+class Deref r where
+  derefIO :: r a -> IO a
+
+{-# NOINLINE deref #-}
+deref :: Deref r => r a -> a
+deref = unsafePerformIO . derefIO
+
+derefEq :: (Deref r, Eq a) => r a -> r a -> Bool
+derefEq = (==) `dot2i` deref
+
+instance Deref DRef where 
+  derefIO (DRef p dc@(DeserializerContext f cv) aRef) = 
+    let addr = arrayRefAddr aRef 
+        r = {-(trace ("(looking up cache at" ++ show addr ++ " wanting an " ++ show (typeOf r))-} modifyMVar cv (return . LRU.lookup addr) >>= 
+            maybe 
+            ((>>= \a -> evaluate a >> (a <$ modifyMVar_ cv (return . {-(trace ("adding to cache at" ++ show addr) $-} LRU.insert addr (toDyn a)))) $
+             fmap (maybe (error "Read error") $ deserializeFromFullArray (cDeser p dc) . (id :: Id (ArrayRange (PrimArray Free Word)))) $
+             derefArrayRef f aRef)
+            (return . fromMaybe (error $ "Wrong type in cache cell " ++ show addr) . fromDynamic)
+    in r
+    
+instance Show a => Show (DRef a) where show = show . deref
+instance Eq a => Eq (DRef a) where (==) = derefEq
+
+instance (Deref ra, Deref rb) => Deref (Sum ra rb) where derefIO = either derefIO derefIO . getSum
+
+instance Deref r => Deref (IRef r) where derefIO = derefIO . getIRef
+instance (Deref r, Eq t) => Eq (IRef r t) where (==) = (==) `dot2i` deref
+instance (Deref r, Show t) => Show (IRef r t) where show = show . deref . getIRef
+
+instance Deref Ref0 where derefIO (Ref0 a) = return a
+instance Show a => Show (Ref0 a) where show = show . deref
+
+instance Deref r => Deref (CRef r) where derefIO = onCRef derefIO return
+instance (Deref r, Show a) => Show (CRef r a) where show = show . deref
+instance (Deref r, Eq a) => Eq (CRef r a) where (==) = derefEq
+ src/Database/Perdure/Digest.hs view
@@ -0,0 +1,77 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, TupleSections, TemplateHaskell #-}
+
+module Database.Perdure.Digest (
+  Digest(..),
+  Skein512Digest,
+  MD5Digest,
+  module Cgm.Data.LongWord
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Word
+import Cgm.Data.LongWord
+import Cgm.Data.Array
+import Cgm.System.Endian
+import System.IO.Unsafe
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Crypto.Hash.MD5 as MD5
+import qualified Crypto.Hash.Skein512 as Skein512
+import Cgm.Data.Structured
+
+-- Recovers a hash function on words from a hash function on a specific byte encoding the words
+-- Word type (size, endianness) must match that of the underlying algorithm.
+-- Output size must be an integer number of words
+unsafeBSToWordHash :: (Allocation f, PinnedArray r, Prim (ArrayElem r)) => (B.ByteString -> B.ByteString) -> r -> PrimArray f (ArrayElem r)
+unsafeBSToWordHash f input = unsafePrimArrayCast $ arrayFromByteString $ unsafePerformIO $ unsafeWithCastArrayByteString (evaluate . f) input
+  
+-- Word size and specified endianness must match that of the underlying algorithm.
+-- Output size must be an integer number of words
+-- There will be no need for this method once we remove the byteswapping layer of the underlying algorithm, and we
+-- have an underlying algorithm that assumes the input is in the platform endianness, instead of a fixed endianness.
+unsafeFixedEndianToWordHash :: forall r. (PinnedArray r, ImmArray r, Endian (ArrayElem r), Prim (ArrayElem r)) => 
+                               Endianness -> (B.ByteString -> B.ByteString) -> r -> PrimArray Free (ArrayElem r)
+unsafeFixedEndianToWordHash e f = 
+  if platformWordEndianness == e
+  then unsafeBSToWordHash f
+  else mapImmArray unswapBytes . (id :: Id (PrimArray Free (ByteSwapped w))) . 
+       unsafeBSToWordHash f . (id :: Id (PrimArray Pinned (ByteSwapped (ArrayElem r)))) . 
+       mapImmArray swapBytes
+
+word128FromArray32LE :: PrimArray f Word32 -> Word128
+word128FromArray32LE a = word128BE (retract splitWord64LE (indexArray a 2, indexArray a 3)) (retract splitWord64LE (indexArray a 0, indexArray a 1))
+
+word128FromArray64LE :: PrimArray f Word64 -> Word128
+word128FromArray64LE a = word128BE (indexArray a 1) (indexArray a 0)
+
+newtype Skein512Digest h = Skein512Digest h deriving (Eq, Show)
+newtype MD5Digest = MD5Digest Word128 deriving (Eq, Show)
+  
+class Eq d => Digest d where
+  type DigestWord d
+  digest :: (ImmArray r, PinnedArray r, ArrayElem r ~ DigestWord d) => r -> d
+
+instance Digest (Skein512Digest Word128) where
+  type DigestWord (Skein512Digest Word128) = Word64
+  digest = {-# SCC "digestSkein" #-} (Skein512Digest . word128FromArray64LE . unsafeFixedEndianToWordHash LittleEndian (Skein512.hash 128))
+  
+instance Digest MD5Digest where
+  type DigestWord MD5Digest = Word32
+  digest = {-# SCC "digestMD5" #-} (MD5Digest . word128FromArray32LE . unsafeFixedEndianToWordHash LittleEndian MD5.hash)
+
+deriveStructured ''MD5Digest
+deriveStructured ''Skein512Digest
+ src/Database/Perdure/History.hs view
@@ -0,0 +1,96 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable #-}
+
+module Database.Perdure.History (
+  History(..),
+  initial,
+  current,
+  insert,
+  updateHistory,
+  updateHistoryM
+  ) where
+
+import Data.Bits
+import Database.Perdure.Persistent
+import Control.Arrow
+import Control.Applicative
+import qualified Control.Monad.State as Std
+import Cgm.Control.Monad.State
+import Control.Monad
+import Database.Perdure.Ref
+import Data.Dynamic
+
+
+-- The History type is used as the state type so as to keep some snapshots of the past, in case data is lost due to a programming error
+-- by the application developer. It is an homogenous collection so the argument type has to take care of versionning.
+-- To avoid needless reserialization of the samples the argument type should be a Ref type.
+
+-- We keep the last maxQueueLength samples inserted, then maxQueueLength samples keeping one out of every two, 
+-- then maxQueueLength samples keeping one out of every four...
+-- The history is never empty, so it is safe to get the current sample.
+
+-- For example:
+-- *Database.Perdure.History> foldr insert empty [0..999] -- with maxQueueLenth == 8
+-- History 1000 [Queue [0,1,2,3,4,5,6,7],Queue [9,11,13,15,17,19,21,23],Queue [27,31,35,39,43,47,51,55],Queue [63,71,79,87,95,103,111
+-- ,119],Queue [127,143,159,175,191,207,223,239],Queue [255,287,319,351,383,415,447,479],Queue [543,607,671,735,799,863,927,991]]
+
+-- If the sampling interval is 1 second, and maxQueueLength is 8,
+-- we get roughly 8 * log3(running-time/k)
+-- For 3 years that's roughly 8*17 = 136 snapshots
+
+newtype Queue a = Queue (CDRef [a]) deriving (Show, Typeable)
+singletonQueue :: a -> Queue a
+singletonQueue a = Queue $ ref [a]
+
+queueInsert :: a -> Queue a -> (Queue a, Maybe a)
+queueInsert a (Queue as) = first (Queue . ref) $ trim (a : deref as) where
+  trim l = 
+    if length l <= maxQueueLength 
+    then (l, Nothing)
+    else case reverse $ take (maxQueueLength + 1) l of -- the 'take' drop elements when we decide to reduce maxQueueLength
+      (o : r) -> (reverse r, Just o) 
+  
+maxQueueLength :: Int
+maxQueueLength = 2
+-- maxQueueLength temporarily reduce from 8 to 2 to
+
+data History a = History Integer [Queue a] deriving (Show, Typeable)
+
+initial :: a -> History a
+initial = History 1 . pure . singletonQueue
+
+updateHistory :: Monad m => Std.StateT a m b -> Std.StateT (History a) m b
+updateHistory = Std.StateT . (\u h -> liftM (second $ flip insert h) (u $ current h) )  . Std.runStateT
+
+updateHistoryM :: Monad m => StateT a m b -> StateT (History a) m b
+updateHistoryM = StateT . (\u h -> liftM (second $ fmap $ flip insert h) (u $ current h) )  . runStateT
+
+current :: History a -> a
+current (History _ (Queue q : _)) = head $ deref q
+
+--Used when we want to flush the history
+--insert :: a -> History a -> History a
+--insert a _ = initial a
+
+insert :: a -> History a -> History a
+insert a (History n qs) = History (n+1) $ ins a qs n where
+  ins o [] m = [singletonQueue o]
+  ins o (q:qr) m = let (q', mo') = queueInsert o q in q' : maybe qr (\o' -> if testBit m 0 then qr else ins o' qr (m `shiftR` 1)) mo'
+                                                      -- we could use a probability instead of this alternating pattern, but this is easier to implement
+
+instance (Typeable a, Persistent a) => Persistent (History a) where persister = structureMap persister                            
+instance (Typeable a, Persistent a) => Persistent (Queue a) where persister = structureMap persister
+deriveStructured ''History
+deriveStructured ''Queue
+ src/Database/Perdure/Incrementer.hs view
@@ -0,0 +1,56 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, Rank2Types, FlexibleContexts, ScopedTypeVariables, BangPatterns, GADTs #-}
+
+module Database.Perdure.Incrementer (
+  incr
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Structured
+import Control.Monad.State
+import Database.Perdure.Persistent
+import Database.Perdure.Space
+import Database.Perdure.Count
+import Database.Perdure.CSerializer(Address)
+import Cgm.Data.Monoid
+import Database.Perdure.ReplicatedFile
+import Cgm.Data.Multiset as MS
+import Debug.Trace
+import Database.Perdure.SpaceBook
+import Database.Perdure.Ref
+
+-- While Decrementer should be used on allocated values (not in s, and may have a count in c), Incrementer is used
+-- on values which have already been written, but we use older values of s and c for which the value to increment
+-- was not yet allocated. So most often it is s, and not in c.
+
+incr :: Persister a -> a -> SpaceBook -> SpaceBook
+incr !p !a !s = case p of
+  PartialWordPersister n -> s
+  PairPersister pb pc -> case a of (b, c) -> incr pc c $ incr pb b s
+  EitherPersister pb pc -> either (incr pb) (incr pc) a s
+  ViewPersister i pb -> incr pb (apply i a) s
+  SummationPersister pi _ f -> f (\i pb _ b -> incr pb b $ incr pi i s) a
+  DRefPersister' -> case a of (DRef _ _ warr) -> 
+                                let referenced = incr persister $ deref a
+                                in either (\(WordNArrayRef _ r _) -> incrRef r referenced) (\(WordNArrayRef _ r _) -> incrRef r referenced) (unwrap warr) s
+  CRefPersister' _ pra -> onCRef (incr pra) (incr persister) a s
+
+incrRef :: forall w. LgMultiple Word64 w =>
+           BasicRef w -> (SpaceBook -> SpaceBook) -> SpaceBook -> SpaceBook
+incrRef r children cs@(SpaceBook c s) =  let rs = refStart r in
+  if isFreeSpace (getLen rs) s 
+  then (\(SpaceBook c' s') -> SpaceBook c' $ removeSpan (refSpan r) s') $ children cs 
+  else SpaceBook (MS.insert rs c) s
+ src/Database/Perdure/LocalStoreFile.hs view
@@ -0,0 +1,335 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TemplateHaskell, TypeFamilies, Rank2Types, GADTs, TupleSections, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts #-}
+
+module Database.Perdure.LocalStoreFile (
+    RawStoreFile(..),
+    storeFileWriteWords,
+    storeFileReadWords,
+    LocalStoreFile,
+    withFileStoreFile,
+    withRawDeviceStoreFile,
+    withRawDeviceStoreFiles,
+    module Database.Perdure.StoreFile,
+    narrowBufsLen,
+    storeFileWrite1,
+    storeFileRead1
+) where
+
+
+import Prelude ()
+import Cgm.Prelude
+import Data.Typeable
+import qualified Data.ByteString as B
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.STM
+import GHC.Conc
+import Data.Word
+import qualified Data.Map as Map
+import Data.Ord
+import System.FilePath
+import Data.Monoid
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Cgm.Data.Word
+import Cgm.Data.Super
+import Cgm.Data.Len
+import Cgm.Data.List
+import Cgm.Data.Maybe
+import Cgm.Data.Functor
+import Cgm.Data.Monoid
+import Cgm.Data.NEList
+import Cgm.Data.Either
+import Cgm.System.Endian
+import Cgm.Control.Concurrent.TThread
+import Cgm.Control.Concurrent.Await
+import Cgm.System.Mem.Alloc
+import Database.Perdure.Validator
+import System.IO
+import System.Posix.Files
+import System.Posix.IO
+import System.Posix.Types
+import Data.Bits
+import Control.Monad.Error hiding (sequence_)
+import Database.Perdure.StoreFile(SyncableStoreFile(..))
+import Debug.Trace
+import Control.DeepSeq
+--import System.Posix.Fsync -- not needed with raw devices
+
+class SyncableStoreFile f => RawStoreFile f where
+  storeFileWriteRaw :: f -> Len Word8 Word64 -> [ArrayRange (PrimArray Pinned Word8)] -> Async Bool ()
+  storeFileReadRaw :: f -> Len Word8 Word64 -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> Async Bool ()
+
+-- The passed endianness is the desired endianness of the words on the media. Here when the endianness does not
+-- match the platform endianness, we do a copy. This case is not very optimized since we anticipate always writing in the
+-- platform endianness.
+storeFileWriteWords :: (Endian w, RawStoreFile f) => f -> Len Word8 Word64 -> Endianness -> [PrimArray Pinned w] -> Async Bool ()
+storeFileWriteWords f addr e bufs = storeFileWriteRaw f addr $ fmap fullArrayRange $ fromWords bufs where
+  fromWords = bool (fmap $ unsafePrimArrayCast . mapImmArray swapBytes) (fmap unsafePrimArrayCast) (e == platformWordEndianness)
+
+-- The passed endianness must be the endianness of the words on the media
+storeFileReadWords :: (LgMultiple w Word8, Endian w, RawStoreFile f) => 
+                      f -> Len Word8 Word64 -> Endianness -> Len w Word32 -> Async (Maybe (PrimArray Pinned w)) ()
+storeFileReadWords f addr e l k = do
+    buf <- stToIO $ mkArray $ refineLen $ apply super <$> l
+    ($ k) $ mapAsync (bool (return Nothing) $ Just <$> processBuf buf) $ storeFileReadRaw f addr (fullArrayRange buf) where
+      processBuf buf = stToIO (toWords <$> unsafeFreezeSTPrimArray buf) -- TODO optimize by swapping bytes in-place then freezing
+      toWords = bool (mapImmArray unswapBytes . unsafePrimArrayCast) unsafePrimArrayCast (e == platformWordEndianness)
+  
+---------------------------------------------------------------------------
+
+newtype LocalStoreFile = LocalStoreFile (MVar DevOp) 
+-- TODO: review to see if this queue is acceptable
+type ByteAddr = Len Word8 Word64
+
+data PosOp = PosOp ByteAddr RWOp deriving Show
+data NonPosOp = Sync (IO ()) | FullBarrier
+instance Show NonPosOp where
+  show (Sync _) = "Sync"
+  show FullBarrier = "FullBarrier"
+  
+type DevOp = Either PosOp NonPosOp
+
+data RWOp = 
+  WriteOp [ArrayRange (PrimArray Pinned Word8)] (Bool -> IO ()) |
+  ReadOp (ArrayRange (STPrimArray RealWorld Pinned Word8)) (Bool -> IO ())
+instance Show RWOp where  
+  show (WriteOp as _) = "WriteOp " ◊ show (sum $ fmap arrayLen as)
+  show (ReadOp a _) = "ReadOp " ◊ show (arrayLen a)
+
+-- TODO investigate why if we do not at force the ByteAddr in PosOp, testStatesDag ends with STM error
+-- Forcing the rest is not necessary for this bug but makes sense here. We do not want the file thread to do work
+-- that should have been done by the client threads. NFData is tricky to use here so we put together this
+-- custom method.
+forceDevOp :: DevOp -> ()
+forceDevOp = either
+             (\(PosOp b r) -> (b `seq`) $
+                              case r of
+                                WriteOp as _ -> sum (fmap arrayLen as) `seq` ()
+                                ReadOp a _ -> arrayLen a `seq` ())
+             (\n -> case n of
+                 Sync _ -> ()
+                 FullBarrier -> ())
+
+instance RawStoreFile LocalStoreFile where
+  storeFileWriteRaw f seek bufs k = queue f $ Left $ PosOp seek $ WriteOp bufs k
+  storeFileReadRaw f seek buf k = queue f $ Left $ PosOp seek $ ReadOp buf k
+
+instance SyncableStoreFile LocalStoreFile where
+  storeFileSync f k = queue f $ Right $ Sync k
+  storeFileFullBarrier f = queue f $ Right FullBarrier
+
+queue :: LocalStoreFile -> DevOp -> IO () 
+queue (LocalStoreFile c) op = evaluate (forceDevOp op) >> putMVar c op {- >> putStrLn ("Queued " ++ show op) -}
+
+-- TODO rework sync mechanism. It was fine when we assumed that all completed write tasks completed successfully, but if some are
+-- to remote files that time out, we want to know when all write completed successfully.
+
+
+narrowBufsLen :: Endian w => [PrimArray Pinned w] -> Len w Word32
+narrowBufsLen = (fromMaybe (error "Array length cannot be expressed as a Word32") . unapply super <$>) . sum . fmap arrayLen
+
+storeFileWrite1 :: (RawStoreFile f, Endian w) => f -> Len Word64 Word64 -> Endianness -> [PrimArray Pinned w] -> IO ()
+storeFileWrite1 f addr e bufs =
+    storeFileWriteWords f (refineLen addr) e bufs $ bool (error "storeFileWrite failed") $ return () -- TODO pass a meaningful k
+
+storeFileRead1 :: (RawStoreFile f, Validator v, ValidatedElem v ~ w, Endian w, LgMultiple w Word8) => 
+                   f -> Len Word64 Word64 -> Len w Word32 -> Endianness -> v -> Async (Maybe (ArrayRange (PrimArray Pinned w))) ()
+storeFileRead1 f addr size e v k =
+    ($ k) $ mapAsync (return . (>>= {-logWhenBad .-} validate v . fullArrayRange)) $ storeFileReadWords f (refineLen addr) e size {-where
+      logWhenBad Nothing = trace "Validation failed" Nothing
+      logWhenBad (Just x) = Just x-}
+
+-- After inspection of GHC.IO.FD, it seems that hFlush only flushes to the OS
+-- Call chain:  
+-- hFlush calls flushWriteBuffer (See http://www.haskell.org/ghc//docs/6.12.2/html/libraries/base-4.2.0.1/src/GHC-IO-Handle.html)
+-- which calls writeBuf (See http://darcs.haskell.org/packages/base/GHC/IO/FD.hs)
+-- which calls RawIO's write (See http://www.haskell.org/ghc/docs/6.12.3/html/libraries/base-4.2.0.2/src/GHC-IO-BufferedIO.html#flushWriteBuffer0)
+
+-- Some links on the subject
+-- http://www.scribd.com/doc/19537350/A-Wander-Through-GHCs-New-IO-Library  
+-- http://lwn.net/Articles/270891/
+-- http://ldn.linuxfoundation.org/article/filesystems-data-preservation-fsync-and-benchmarks-pt-1
+-- http://www.linux-archive.org/device-mapper-development/422441-block-fs-replace-hardbarrier-flush-fua-take-2-a.html
+-- FSync FFI is available here: http://hackage.haskell.org/packages/archive/cautious-file/0.1.5/doc/html/src/System-Posix-Fsync.html
+  
+
+--
+
+class Show a => Schedule a where
+  emptySchedule :: a
+  insertOp :: PosOp -> a -> a
+  nextOp :: a -> Maybe (PosOp, a)
+  
+-- Multimap through a Map of NEList
+minViewWithKeyNE :: Ord k => Map.Map k (NEList v) -> Maybe ((k, v), Map.Map k (NEList v))
+minViewWithKeyNE = (getSingle <$>) . Map.minViewWithKey where
+  getSingle ((k, ne), m) = flip onNEList ne $ \single ne' -> ((k, single), maybe id (Map.insert k) ne' m)
+
+data CLook = CLook ByteAddr (Map.Map ByteAddr (NEList PosOp)) (Map.Map ByteAddr (NEList PosOp)) deriving Show
+updateLow u (CLook c low high) = CLook c (u low) high
+updateHigh u (CLook c low high) = CLook c low (u high)
+instance Schedule CLook where
+  emptySchedule = CLook 0 Map.empty Map.empty
+  insertOp op@(PosOp seek _) s@(CLook c _ _) = {- (\s' -> trace ("insertOp on " ++ show s) s') $ -} bool updateLow updateHigh (seek >= c) (Map.insertWith neAppend seek (neSingleton op)) s
+  nextOp s@(CLook _ low high) = {- trace ("nextOp on " ++ show s) $ -} useHighMin `firstJust` useLowMin where
+    useLowMin = (\((pos, op), low') -> (op, CLook pos low' high)) <$> minViewWithKeyNE low
+    useHighMin = (\((pos, op), high') -> (op, CLook pos low high')) <$> minViewWithKeyNE high
+
+--
+    
+instance Error () where
+  noMsg = ()
+  strMsg _ = ()
+
+class Show f => RawFile f where
+  fileWriteRaw :: f -> Len Word8 Word64 -> [ArrayRange (PrimArray Pinned Word8)] -> ErrorT () IO ()
+  fileReadRaw :: f -> Len Word8 Word64 -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO ()
+  fileFlush :: f -> IO ()
+  
+instance RawFile Handle where
+  fileWriteRaw h seek bufs = lift $ hSeekX h seek >> sequence_ (withArrayPtr (hPutBufLen h) <$> bufs) -- TODO fix error handling
+  fileReadRaw h seek buf = ErrorT $ fmap (boolEither () () . (== arrayLen buf)) $ hSeekX h seek >> withArrayPtr (hGetBufLen h) buf
+  fileFlush = hFlush  -- todo fsync or fdatasync on FD so we flush to the drive (and the platter?, see comment below)
+
+performAll :: (Schedule s, RawFile f) => f -> s -> IO ()
+performAll f s = maybe (return ()) (\(op, s') -> perform f op >> performAll f s') $ nextOp s
+
+perform :: RawFile f => f -> PosOp -> IO ()
+perform f p@(PosOp seek rw) = {- putStrLn ("about to perform " ++ show p) >> -} case rw of 
+  WriteOp bufs k -> runErrorT (fileWriteRaw f seek bufs) >>= (log >>) . either (const $ k False) (const $ k True) where
+    --log = putStrLn ("Wrote " ++ showLen (sum $ fmap arrayLen bufs) ++ " at " ++ showLen seek ++ " on " ++ show f {- ++ ": " ++ show bufs -})
+    log = return ()
+    --log = putStr "w"
+  ReadOp buf k -> runErrorT (fileReadRaw f seek buf) >>= (log >>) . either (const $ k False) (const $ k True) where
+    --log = putStrLn ("Read " ++ showLen (arrayLen buf) ++ " at " ++ showLen seek ++ " from " ++ show f)
+    log = return ()
+
+process :: (Schedule s, RawFile f) => MVar DevOp -> f -> s -> IO ()
+process c f s = {- (putStrLn ("Process on " ++ show s) >>) $ -} maybe
+                (takeMVar c >>= incoming) 
+                (\(op, s') -> tryTakeMVar c >>= maybe (perform f op >> process c f s') incoming) $ 
+                nextOp s where
+  incoming :: DevOp -> IO ()
+  incoming = (>>= process c f) . either 
+             (return . flip insertOp s) 
+             (\op -> emptySchedule <$ 
+                     (performAll f s >> case op of
+                         Sync k -> fileFlush f >> k
+                         FullBarrier -> fileFlush f
+                     )
+             ) {- . (\op -> trace ("incoming") op) -}
+  
+-- Seeks to the given position, expanding the file as necessary
+hSeekX :: Handle -> ByteAddr -> IO ()
+hSeekX h seek = do
+    size <- fromIntegral <$> hFileSize h
+    when (size <= seek) $ do
+      hSeek h AbsoluteSeek (fromIntegral size)
+      hWriteZeros h $ seek - size
+    hSeek h AbsoluteSeek (fromIntegral seek)
+
+hWriteZeros :: Handle -> ByteAddr -> IO ()
+hWriteZeros h numZeros = when (numZeros > 0) $ do
+  let batch = min numZeros (16*1024*1024)
+  B.hPut h (B.replicate (fromIntegral batch) 0)
+  hWriteZeros h (numZeros - batch)
+
+newtype ChildException = ChildException SomeException deriving (Typeable, Show)
+instance Exception ChildException
+
+-- Do not make concurrent calls on the same file, place concurrency in the passed function 'user'
+withFileStoreFile :: FilePath -> (LocalStoreFile -> IO a) -> ErrorT String IO a
+withFileStoreFile path user = lift $ withBinaryFile path ReadWriteMode $ \h -> hSetBuffering h NoBuffering >> withRawFile h user
+  
+withRawDeviceStoreFile :: FilePath -> (LocalStoreFile -> IO a) -> ErrorT String IO a
+withRawDeviceStoreFile path user =
+  ErrorT $ bracket (openFd path ReadWrite Nothing $ defaultFileFlags {exclusive = True, append = True}) closeFd $ 
+  \fd -> runErrorT $
+         do fs <- lift $ getFdStatus fd
+            bool (throwError "Not a raw device") (lift $ withRawFile (RawDevice fd fs 9) user) $ isCharacterDevice fs
+
+-- Could be generalized to allow mixing rawDevices and files. We will need to do that eventually to support remote replicas
+withRawDeviceStoreFiles :: [FilePath] -> ([LocalStoreFile] -> IO a) -> ErrorT String IO a
+withRawDeviceStoreFiles ps user = foldr (\p u fs ->  (>>= ErrorT . pure) $ withRawDeviceStoreFile p $ \f -> runErrorT $ u $ fs ◊ [f]) (lift . user) ps []
+
+toFileOffset :: Integral n => Len Word8 n -> FileOffset
+toFileOffset = fromIntegral . getLen
+
+toByteCount :: Integral n => Len Word8 n -> ByteCount
+toByteCount = fromIntegral . getLen
+
+fdSeekLen :: Fd -> ByteAddr -> IO ()
+fdSeekLen fd seek = () <$ fdSeek fd AbsoluteSeek (toFileOffset seek)
+
+-- TODO: consider adding support for a 'STPrimArray RealWorld Pinned Block', and a matching address type, that would enfoce the above requirements
+-- However we would have to cast/view it as an array of Word8 later on.
+-- | Array's size and start must be aligned on the block size, and the ByteAddr too.
+fdReadArray :: Fd -> ByteAddr -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO ()
+fdReadArray fd start a = ErrorT $ fmap (boolEither () () . (==) (toByteCount $ arrayLen a)) $ 
+                         fdSeekLen fd start >> withArrayPtr (\ptr len -> fdReadBuf fd ptr $ toByteCount len) a
+
+fdWriteArray :: Fd -> ByteAddr -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO ()
+fdWriteArray fd start a = ErrorT $ fmap (boolEither () () . (==) (toByteCount $ arrayLen a)) $ 
+                          fdSeekLen fd start >> withArrayPtr (\ptr len -> fdWriteBuf fd ptr $ toByteCount len) a
+
+-- A bit of info on raw devices that i did not find easily elsewhere: http://www.win.tue.nl/~aeb/linux/lk/lk-11.html#ss11.4
+
+data RawDevice = RawDevice Fd FileStatus Int
+rawDeviceBlockBytes :: RawDevice -> Len Word8 Word
+rawDeviceBlockBytes (RawDevice _ _ lg) = unsafeLen $ 1 `shiftL` lg
+instance Show RawDevice where show (RawDevice fd fs _) = show $ specialDeviceID fs
+-- TODO merge consecutive writes to improve performance (avoids many needless reads to preserve data that will be overwritten)
+instance RawFile RawDevice where                              
+  fileWriteRaw r@(RawDevice fd _ blockBytes) start bufs =
+    let len = up $ sum $ arrayLen <$> bufs in
+    withBlockArray r start len $ ((. fullArrayRange) .) $ \tStart t -> 
+    do
+      let bb = rawDeviceBlockBytes r
+      let tLen = arrayLen t
+      let tEnd = tStart + up tLen
+      when (tStart < start) $ fdReadArray fd tStart $ headArrayRange bb t
+      when (start + len < tEnd) $ fdReadArray fd (tEnd - up bb) $ skipArrayRange (tLen - bb)  t
+      let dest = skipArrayRange (fromJust $ unapply super $ start - tStart) t
+      lift $ stToIO $ foldlM (\d b -> skipArrayRange (arrayLen b) d <$ mapMArrayCopyImm return b d) dest bufs
+      fdWriteArray fd tStart t
+  fileReadRaw r@(RawDevice fd _ _) start buf =
+    withBlockArray r start (up $ arrayLen buf) $ ((. fullArrayRange) .) $ \tStart t -> 
+     do 
+       -- liftIO $ putStrLn $ "Before fdReadArray " ++ show start
+       fdReadArray fd tStart t
+       let rangeToCopy = skipArrayRange (fromJust $ unapply super $ start - tStart) t
+       lift $ stToIO (mapMArrayCopy return rangeToCopy buf)
+  fileFlush _ = return ()
+  
+-- Takes start and length, and passes rounded start and an aligned buffer
+withBlockArray :: MonadIO m => RawDevice -> ByteAddr -> ByteAddr -> (ByteAddr -> STPrimArray RealWorld Pinned Word8 -> m a) -> m a
+withBlockArray r@(RawDevice fd _ lgBlockBytes) seek len f = 
+  let blockBytes = rawDeviceBlockBytes r
+      seek' = getLen seek
+      len' = getLen len
+      start = (seek' `shiftR` lgBlockBytes) `shiftL` lgBlockBytes
+      end = ((seek' + len' + up (getLen blockBytes) - 1) `shiftR` lgBlockBytes) `shiftL` lgBlockBytes
+  in liftIO (stToIO $ newAlignedPinnedWord8Array blockBytes $ unsafeLen $ fromJust $ unapply super $ end - start) >>= 
+     \r -> f (unsafeLen start)
+           -- $ trace ("withBlockArray blockBytes=" ++ show blockBytes ++ " start=" ++ show (unsafeLen start) ++ " size=" ++ (show $ arrayLen r))
+           r
+  
+withRawFile :: (RawFile f, Show f) => f -> (LocalStoreFile -> IO a) -> IO a
+withRawFile f user = do
+  chan <- newEmptyMVar
+  runWithDeamon 
+    ("User of " ++ show f, user $ LocalStoreFile chan) 
+    ("Server for " ++ show f, bracket_ (return ()) (return (){-putStrLn $ "Server for " ++ show f ++ " ended"-}) $ process chan f (emptySchedule :: CLook))
+ src/Database/Perdure/Package.hs view
@@ -0,0 +1,19 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+module Database.Perdure.Package(
+  perdurePackage
+  ) where
+
+perdurePackage :: String
+perdurePackage = "perdure-0.1.0"
+ src/Database/Perdure/Persistent.hs view
@@ -0,0 +1,329 @@+{-+Copyright 2010-2012 Cognimeta Inc.++Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at++     http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software distributed under the License is+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express+or implied. See the License for the specific language governing permissions and limitations under the License.+-}++{-# LANGUAGE ScopedTypeVariables, +  MultiParamTypeClasses, +  FlexibleInstances, +  FlexibleContexts, +  TupleSections,+  TypeOperators,+  FunctionalDependencies, +  GADTs, +  GeneralizedNewtypeDeriving, +  RankNTypes, +  KindSignatures, +  TemplateHaskell, +  TypeFamilies, +  UndecidableInstances, +  DeriveFunctor, +  DeriveDataTypeable #-}++module Database.Perdure.Persistent (+  Persister(..),+  Persistent(..),+  Persistent1(..),+  Persistent1_(..),+  LgPersistent1_(..),+  RefPersister(..),+  RefPersistent(..),+  (&.),+  (|.),+  lenPersister,+  summationPersister,+  ratioPersister,  +  wordPersister,+  maybePersister,+  shortcutPersister,+  (>.),+  listPersister,+  ReplicatedFile,+  module Database.Perdure.CRef,+  DeserializerContext(..),+  DRef(..), --FIXME, we want to export constructor only to implementors+  WordArrayRef(..),+  WordNArrayRef(..),+  WArrayRef,+  IRef(..),+  Ref0(..),+  CDRef,+  Cache,+  module Database.Perdure.StoreFile,+  module Database.Perdure.LocalStoreFile,+  module Cgm.Data.Structured+) where++import Prelude ()+import Cgm.Prelude+import Data.Word+import Data.Int+import System.IO.Unsafe+import Cgm.Data.WordN+import Cgm.Data.Word+import Cgm.Data.Len+import Cgm.Data.Structured+import Cgm.Data.Functor.Sum+import Database.Perdure.LocalStoreFile+--import Database.Perdure.SoftRef+import Data.Ratio+import Data.Lens+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Time.Calendar+import Data.Time.Clock+import Database.Perdure.Digest+import Database.Perdure.Validator+import Database.Perdure.WValidator+import Database.Perdure.StoreFile+import Database.Perdure.ReplicatedFile+import Database.Perdure.Allocator+import Cgm.System.Endian+import Data.Ord+import Data.Char+import Data.Binary.IEEE754+import Cgm.Data.List+import Data.Ratio+import Data.Bits+import Database.Perdure.CRef+import Data.Cache.LRU+import Data.Dynamic+import Control.Concurrent.MVar+import Cgm.Data.Typeable++data WordNArrayRef v (r :: * -> *) = WordNArrayRef !v !(r (ValidatedElem v)) !Endianness++data WordArrayRef r32 r64 (r :: * -> *) = Word32ArrayRef !(r32 r) | Word64ArrayRef !(r64 r)++type WArrayRef = WordArrayRef (WordNArrayRef W32Validator) (WordNArrayRef W64Validator)++type Cache = LRU (Len Word64 Word64) Dynamic++data DeserializerContext = forall f. (StoreFile f, StoreRef f ~ BasicRef) => DeserializerContext {dcFile :: f, dcCache :: MVar Cache}++data DRef a where+  DRef :: Typeable a => !(Persister a) -> !DeserializerContext -> !(WArrayRef BasicRef) -> DRef a deriving Typeable++class LgPersistent1_ (r :: * -> *) where lgPersister1_ :: (LgMultiple Word64 w) => Persister (r w)++data Persister a where+  PartialWordPersister :: !(Len Bool Word) -> Persister Word -- Do not export to user+  PairPersister :: !(Persister a) -> !(Persister b) -> Persister (a, b)+  EitherPersister :: !(Persister a) -> !(Persister b) -> Persister (Either a b)+  ViewPersister :: !(InjectionA' a b) -> Persister b -> Persister a -- Not strict in Persister b because here we want to allow cycles+  SummationPersister :: !(Persister i) -> +                        !(forall z. (forall b. Persister b -> (b -> a) -> z) -> i -> z) -> +                        !(forall z. (forall b. i -> Persister b -> (b -> a) -> b -> z) -> a -> z) -> Persister a+  -- The index persister above should not contain refs because CSerializer uses the (b -> a), which ignores any storage changes to the i.+  -- The i is not stored as is in memory.+  DRefPersister' :: (Typeable a, Persistent a) => Persister (DRef a)+                    -- Persistent a instead of Persister a, multiple DRefs can point to the same location, so they must share the+                    -- same persister for a. Unless we were to support persistence of persisters, in which case the persister could+                    -- be encoded at the start of the referenced data (might be wasteful to always do this though). Persistence of+                    -- persisters means restricting ViewPersister to persistable views however (possibly only Structure), and+                    -- then we would also need to persist data with cycles.+  CRefPersister' :: (Typeable a, Persistent a) => !(RefPersister r) -> !(Persister (r a)) -> Persister (CRef r a)++instance InjectionACofunctor Persister where iacomap pb i = ViewPersister (injectionA' i) pb++infixr 7 &.+(&.) :: Persister a -> Persister b -> Persister (a, b)+(&.) = PairPersister++infixr 6 |.+(|.) :: Persister a -> Persister b -> Persister (Either a b)+(|.) = EitherPersister+  +summationPersister :: (Persister i) -> +                        (forall z. (forall b. Persister b -> (b -> a) -> z) -> i -> z) -> +                        (forall z. (forall b. i -> Persister b -> (b -> a) -> b -> z) -> a -> z) -> Persister a+summationPersister = SummationPersister  +  +data RefPersister r where+  Ref0Persister :: RefPersister Ref0+  RefView ::  (forall a. rb a -> ra a) -> RefPersister rb -> RefPersister ra+  SizeRefPersister :: Len Bool Word -> RefPersister (Sum Ref0 DRef)+  CRefPersister :: RefPersister r -> RefPersister (CRef r)+  DRefPersister :: RefPersister DRef+  IRefPersister :: RefPersister r -> RefPersister (IRef r)++class RefPersistent r where refPersister :: RefPersister r+                                                  +instance RefPersistent Ref0 where refPersister = Ref0Persister+instance RefPersistent r => RefPersistent (CRef r) where refPersister = CRefPersister refPersister+instance RefPersistent DRef where refPersister = DRefPersister+instance RefPersistent r => RefPersistent (IRef r) where refPersister = IRefPersister refPersister++class Persistent1_ (r :: * -> *) where persister1_ :: Persister (r a)+                                                       +class Persistent2_ (r :: * -> * -> *) where persister2_ :: Persistent f => Persister (r f a)++class Persistent1 r where persister1 :: (Typeable a, Persistent a) => Persister (r a)+instance Persistent1 Ref0 where persister1 = structureMap persister+instance Persistent1 DRef where persister1 = DRefPersister'+instance Persistent1 r => Persistent1 (IRef r) where persister1 = structureMap persister1+instance (RefPersistent r, Persistent1 r) => Persistent1 (CRef r) where persister1 = CRefPersister' refPersister persister1+instance (Persistent1 ra, Persistent1 rb) => Persistent1 (Sum ra rb) where persister1 = structureMap $ persister1 |. persister1++-- Persistent++class Persistent a where persister :: Persister a++instance Persistent () where+  {-# INLINE persister #-}+  persister = PartialWordPersister 0 `iacomap` uncheckedInjectionA (\() -> 0) (const $ Just ())+instance Persistent Bool where+  {-# INLINE persister #-}+  persister = persister `iacomap` boolAsWord+instance Persistent Char where +  {-# INLINE persister #-}+  persister = persister `iacomap` (uncheckedBijection (fromIntegral . ord) (chr . fromIntegral) :: Bijection' Char (RWord Word32 D21))+instance (Persistent a, Persistent b) => Persistent (Either a b) where+  {-# INLINE persister #-}+  persister = persister |. persister+instance (Persistent a1, Persistent a2) => Persistent (a1, a2) where+  {-# INLINE persister #-}+  persister = persister &. persister+instance (Persistent a1, Persistent a2, Persistent a3) => Persistent (a1,a2,a3) where persister = structureMap persister+instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4) => Persistent (a1,a2,a3,a4) where persister = structureMap persister+instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4, Persistent a5) => Persistent (a1,a2,a3,a4,a5) where +  persister = structureMap persister+instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4, Persistent a5, Persistent a6) => Persistent (a1,a2,a3,a4,a5,a6) where +  persister = structureMap persister+instance Persistent Ordering where persister = structureMap persister+instance Persistent Word where +  {-# INLINE persister #-}+  persister = wordPersister+instance Persistent Word8 where +  {-# INLINE persister #-}+  persister = unsafeBitsPersister+instance Persistent Word16 where +  {-# INLINE persister #-}+  persister = unsafeBitsPersister+instance Persistent Word32 where +  {-# INLINE persister #-}+  persister = onWordConv (wordPersister `iacomap` inv wordConv) unsafeBitsPersister+instance Persistent Word64 where +  {-# INLINE persister #-}+  persister = onWordConv (persister `iacomap` splitWord64LE) (wordPersister `iacomap` inv wordConv)+instance Persistent Int where persister = persister `iacomap` unsigned+instance Persistent Int8 where persister = persister `iacomap` unsigned+instance Persistent Int16 where persister = persister `iacomap` unsigned+instance Persistent Int32 where persister = persister `iacomap` unsigned+instance Persistent Int64 where persister = persister `iacomap` unsigned+instance Persistent Float where persister = persister `iacomap` uncheckedBijection floatToWord wordToFloat +instance Persistent Double where persister = persister `iacomap` uncheckedBijection doubleToWord wordToDouble+instance Persistent Integer where persister = persister `iacomap` integerWords+instance (Integral a, Persistent a) => Persistent (Ratio a) where persister = ratioPersister persister+instance RWordC Word8 n => Persistent (RWord Word8 n) where persister = unsafeBitsPersister+instance RWordC Word16 n => Persistent (RWord Word16 n) where persister = unsafeBitsPersister+instance RWordC Word32 n => Persistent (RWord Word32 n) where persister = unsafeBitsPersister+instance RWordC Word64 n => Persistent (RWord Word64 n) where +  persister = bool (onWordConv r64on32 unsafeBitsPersister) (PartialWordPersister n' `iacomap` unsafeIntegralAsWord) $ n' <= 32 where+      n' = (at :: At (RWord Word64 n)) bitSizeLen+      r64on32 = (persister &. partialWord32Persister) `iacomap` (injectionA' splitWord64LE . injectionA' super)+      partialWord32Persister = PartialWordPersister (n' - 32) `iacomap` unsafeIntegralAsWord+      -- spliting into a (Word32, RWord32) would be cleaner, but would require addSub as below, +      -- and there might be some performance problems with that+instance Persistent a => Persistent (Maybe a) where persister = maybePersister persister+instance Persistent a => Persistent [a] where persister = listPersister persister+instance Persistent a => Persistent (Ref0 a) where persister = structureMap persister+instance Persistent W32Validator where persister = structureMap persister+instance Persistent W64Validator where persister = structureMap persister+instance Persistent Word128 where persister = structureMap persister+instance Persistent MD5Digest where persister = structureMap persister                                   +instance Persistent h => Persistent (Skein512Digest h) where persister = structureMap persister+instance (Persistent1 r, Typeable a, Persistent a) => Persistent (IRef r a) where persister = persister1+instance (Persistent1 ra, Persistent1 rb, Typeable a, Persistent a) => Persistent ((Sum ra rb) a) where persister = structureMap $ persister1 |. persister1+instance (RefPersistent r, Persistent1 r, Typeable a, Persistent a) => Persistent (CRef r a) where persister = persister1+instance Persistent a => Persistent (Len u a) where persister = lenPersister persister+instance (Ord k, Persistent k, Persistent v) => Persistent (Map.Map k v) where persister = persister `iacomap` (uncheckedInjection Map.toList Map.fromList)+instance (Ord k, Persistent k) => Persistent (Set.Set k) where persister = persister `iacomap` (uncheckedInjection Set.toList Set.fromList)+instance Persistent Day where persister = structureMap persister                            +instance Persistent UTCTime where persister = structureMap persister+instance Persistent DiffTime where persister = persister `iacomap` (uncheckedInjection toRational fromRational)+instance Persistent c => Persistent (() -> c) where+  persister = persister `iacomap` (uncheckedBijection ($ ()) const)+instance (Persistent (a -> c), Persistent (b -> c)) => Persistent (Either a b -> c) where+  persister = persister `iacomap` (uncheckedBijection (\f -> (f . Left, f . Right)) (\(fa, fb) -> either fa fb))++instance (Typeable a, Persistent a) => Persistent (DRef a) where persister = persister1+instance Persistent (BasicRef w) where persister = structureMap persister+instance LgPersistent1_ BasicRef where lgPersister1_ = persister+instance (Persistent v, LgPersistent1_ r, LgMultiple Word64 (ValidatedElem v)) => Persistent (WordNArrayRef v r) where +  persister = structureMap $ persister &. lgPersister1_ &. (structureMap persister)+instance (Persistent (r32 r), Persistent (r64 r)) => Persistent (WordArrayRef r32 r64 r) where +  persister = structureMap $ persister |. persister++{-# INLINE listPersister #-}  +listPersister :: List a => Persister (Listed a) -> Persister a+listPersister elemPersister = (maybePersister $ elemPersister &. listPersister elemPersister) `iacomap` listStructure++-- Takes persisters for 2 types, and an injection from the smaller type 'a' to the larger type 'b', and gives a persister for the larger type which uses+-- the smaller type representation when possible, plus one bit to identify which representation is used.+shortcutPersister :: InjectionM i => i a b -> Persister b -> Persister a -> Persister b+shortcutPersister i b a = (b |. a) `iacomap` eitherI where+  eitherI = uncheckedInjection (\x -> ($ x) $ maybe (Left x) Right . unapply i) (either id $ apply i)++-- Specialization of shortcutPersister with the 'super' injection.+infixl 9 >.+(>.) :: Super a b => Persister b -> Persister a -> Persister b+(>.) = shortcutPersister super++maybePersister :: Persister a -> Persister (Maybe a)+maybePersister elemPersister = structureMap $ persister |. elemPersister++bitPersister :: Persister Word -- Do not export to user+bitPersister = PartialWordPersister 1+wordPersister :: Persister Word+wordPersister = PartialWordPersister wordBits++-- prefer wordPersister when writing a full word+-- unsafe because (bitSize a) size must not exceed Word size+unsafeBitsPersister :: forall a. (Bits a, Integral a) => Persister a+unsafeBitsPersister = PartialWordPersister ((at :: At a) bitSizeLen) `iacomap` unsafeIntegralAsWord++-- unsafe because (bitSize a) size must not exceed Word size+unsafeIntegralAsWord :: Integral a => Injection' a Word+unsafeIntegralAsWord = uncheckedInjection fromIntegral fromIntegral++lenPersister :: Persister a -> Persister (Len u a)+lenPersister = structureMap++{-# INLINE ratioPersister #-}  +ratioPersister :: Integral a => Persister a -> Persister (Ratio a)+ratioPersister elemPersister =+  (elemPersister &. elemPersister) `iacomap` (uncheckedBijection (numerator &&& denominator) (uncurry (%)))++integerWords :: Bijection' Integer (Int32, [Word32])+integerWords = uncheckedBijection+               (unfoldlE $ \i -> let o = fromIntegral i in if fromIntegral o == i then Left o else Right (i `shiftR` 32, fromIntegral i))+               (\(i, l) -> foldl (\x d -> (x `shiftL` 32) + fromIntegral d) (fromIntegral i) l)+++-- IRef++newtype IRef r t = IRef {getIRef :: r t} deriving (Functor, Applicative)++-- Ref0+                                                    +newtype Ref0 a = Ref0 a deriving (Functor, Eq)++-- Temporary Aliases+type CDRef = CRef DRef++deriveStructured ''Ref0+deriveStructured ''IRef+deriveStructured ''Day+deriveStructured ''UTCTime+deriveStructured ''WordNArrayRef                                                               +deriveStructured ''WordArrayRef+
+ src/Database/Perdure/RNF.hs view
@@ -0,0 +1,39 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts, GADTs #-}
+
+module Database.Perdure.RNF (
+  prnf
+  ) where
+
+import Control.Applicative
+import System.IO.Unsafe
+import Cgm.Data.Word
+import Cgm.Data.WordN
+import Cgm.Control.InFunctor
+import Cgm.Control.Combinators
+import Database.Perdure.Persistent
+--import Database.Perdure.SoftRef
+--import Database.Perdure.WriteRef
+import Database.Perdure.CRef
+
+prnf :: Persister a -> a -> ()
+prnf p = case p of
+  PartialWordPersister n -> (`seq` ())
+  PairPersister pa pb -> \(a, b) -> prnf pa a `seq` prnf pb b
+  EitherPersister pa pb -> either (prnf pa) (prnf pb)
+  ViewPersister i pb -> prnf pb . apply i
+  SummationPersister pi _ s -> s (\i pb _ b -> prnf pi i `seq` prnf pb b)
+  DRefPersister' -> (`seq` ())  -- Do not load, the persisted reference is already fully evaluated
+  CRefPersister' _ pra -> onCRef (prnf pra) (prnf persister)
+ src/Database/Perdure/Ref.hs view
@@ -0,0 +1,43 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+
+module Database.Perdure.Ref (
+  Ref(..),
+  ref,
+  refLens,
+  module Database.Perdure.Deref,
+  ) where
+
+import System.IO.Unsafe
+import Cgm.Data.Functor.Sum
+import Cgm.Control.Combinators
+import Database.Perdure.Deref
+import Data.Lens
+import Database.Perdure.Persistent
+import Control.Applicative
+
+class Deref r => Ref r where
+  refIO :: a -> IO (r a)
+
+{-# NOINLINE ref #-}
+ref :: Ref r => a -> r a
+ref = unsafePerformIO . refIO
+
+refLens :: Ref r => Lens (r a) a
+refLens = lens deref $ const . ref
+
+instance Ref r => Ref (IRef r) where refIO = (IRef <$>) . refIO
+instance Ref Ref0 where refIO = return . Ref0
+instance Deref r => Ref (CRef r) where refIO = return . ToRef
+instance Deref r => Functor (CRef r) where fmap f = ref . f . deref
+ src/Database/Perdure/ReplicatedFile.hs view
@@ -0,0 +1,41 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Perdure.ReplicatedFile (
+  ReplicatedFile(..)
+  ) where
+
+import Control.Applicative
+import Database.Perdure.StoreFile
+import Database.Perdure.LocalStoreFile
+import Cgm.Control.Concurrent.NotificationCount
+import Cgm.Data.Word
+
+newtype ReplicatedFile = ReplicatedFile [LocalStoreFile]
+
+instance StoreFile ReplicatedFile where
+  type StoreRef ReplicatedFile = BasicRef
+  storeFileWrite (ReplicatedFile fs) addr e bufs = do
+    sequence_ $ fmap (\f -> storeFileWrite1 f addr e bufs) fs
+    return (BasicRef addr $ narrowBufsLen bufs)
+  storeFileRead (ReplicatedFile fs) (BasicRef addr size) e v k =
+    foldr (\f retry -> await1 (storeFileRead1 f addr size e v) >>= maybe retry (k . Just)) (k Nothing) fs 
+  
+instance SyncableStoreFile ReplicatedFile where
+  storeFileSync (ReplicatedFile fs) = withNotificationCount $ \n -> sequence_ $ (notifying n . storeFileSync) <$> fs
+  storeFileFullBarrier (ReplicatedFile fs) = sequence_ $ storeFileFullBarrier <$> fs
+
+-- TODO see if we can have the user threads perform the digest checks
+
+ src/Database/Perdure/Rev.hs view
@@ -0,0 +1,81 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, RankNTypes, EmptyDataDecls, DeriveDataTypeable, TypeOperators, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-}
+
+module Database.Perdure.Rev(
+  (:>)(..),
+  onRev,
+  NoRev,
+  onNoRev,
+  toCurrent,
+  toOnlyRev,
+  revPersister,
+  latestLens
+  ) where
+
+import Database.Perdure.Persistent
+import Database.Perdure.Ref
+import Cgm.Data.Tagged
+import Data.Lens
+import Data.Typeable
+
+infixr 1 :>
+-- | A data type which is equivalent to Either, but which is persisted in an open manner which allows us to chain new
+-- variants on the left. As more variants are added (going from NoRev to V1 :> NoRev and then to V2 :> V1 :> NoRev), the
+-- persisted representation gets expanded without breaking the representation of previous variants.
+-- We do not use Either because of the risk of persisting it in the standard manner and therefore losing upgradability.
+data a :> b = Current a | Previous b deriving Typeable
+
+onRev :: (a -> z) -> (b -> z) -> (a :> b) -> z
+onRev az bz r = case r of {Current a -> az a; Previous b -> bz b}
+
+-- | An uninhabited type used as the last (rightmost) type in chains of '(:>)'
+data NoRev deriving Typeable
+onNoRev :: NoRev -> z
+onNoRev _ = undefined
+
+toOnlyRev :: (a :> NoRev) -> a
+toOnlyRev = toCurrent onNoRev
+
+-- | Converts a chain of revisions to the 'Current' type, given a way to convert the 'Previous' type to the 'Current' type.
+toCurrent :: (b -> a) -> (a :> b) -> a
+toCurrent = onRev id
+
+class Rev a where lastRev :: Tagged a Integer
+instance Rev NoRev where lastRev = tag (-1)
+instance Rev b => Rev (a :> b) where lastRev = tag $ (at :: At b) lastRev +  1
+
+class Rev a => PersistentRev a where
+  deserRev :: (forall b. Persister b -> (b -> a) -> z) -> Integer -> z
+  serRev :: (forall b. Integer -> Persister b -> (b -> a) -> b -> z) -> a -> z
+instance PersistentRev NoRev where  
+  deserRev _ _ = error "bad index when deserializing Rev"
+  serRev f = onNoRev
+instance (Persistent b, PersistentRev r) => PersistentRev (b :> r) where
+  deserRev f i = if i == (at :: At (b :> r)) lastRev then f persister Current else deserRev ((. (Previous .)) . f) i
+  serRev f = onRev (f ((at :: At (b :> r)) lastRev) persister Current) (serRev $ ((. (Previous .)) .) . f)
+  
+-- | The persister for '(:>)' first writes out the numeric index, from the right, in the chain of revisions. This way the chain of alternative
+-- revisions can lengthen without changing the indices of past revisions.
+revPersister :: PersistentRev a => Persister a
+revPersister = summationPersister persister deserRev serRev
+
+instance Persistent NoRev where persister = revPersister
+instance PersistentRev (b :> r) => Persistent (b :> r) where persister = revPersister                                
+
+-- | This is not a legal lens since it violates the law which says that setting back what you got must have no effect.
+-- Here it is almost true since the only effect it has is to upgrade to the current representation, an idempotent change
+-- for a semantically equivalent value.                                                             
+latestLens :: (b -> a) -> Lens (a :> b) a
+latestLens toLatest = lens (toCurrent toLatest) (const . Current)
+ src/Database/Perdure/RootValidator.hs view
@@ -0,0 +1,70 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, TupleSections, ScopedTypeVariables, FlexibleInstances, UndecidableInstances #-}
+
+module Database.Perdure.RootValidator (
+  RootValidator(..),
+  ValidationDigestWord(..),
+  module Database.Perdure.Validator
+  ) where
+
+import Data.Word
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.Binary as Binary
+import Crypto.Hash.Tiger
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import System.IO.Unsafe
+import Database.Perdure.Digest
+import Cgm.Data.Maybe
+import Cgm.Data.Len
+import Database.Perdure.Validator
+import Database.Perdure.CSerializer
+import Database.Perdure.CDeserializer
+import Cgm.Control.Concurrent.Await
+import Cgm.Control.Combinators
+import Database.Perdure.AllocCopy
+
+-- ValidationDigest assiciates a particular digest method to each word type to digest (Word32 and Word64)
+-- It must be a right inverse of DigestWord.
+-- We'd need a superclass equality constraint here.
+-- As a first wordaround attempt we place the equality constraint in instances
+-- Users fail with an infinite type error.
+-- Read a relevant post: http://www.haskell.org/pipermail/haskell-cafe/2009-January/053696.html                                                                  
+-- Actual workaround we used: removed Digest from superclass of ValidationDigestWord, added digest' method which delegates to digest
+class (AllocCopy w, Deserializable w, LgMultiple w Bool, LgMultiple w Word8, LgMultiple Word64 w, Persistent (ValidationDigest w), 
+       Eq (ValidationDigest w), Show (ValidationDigest w)) => ValidationDigestWord w where 
+  type ValidationDigest w
+  digest' :: (ImmArray r, PinnedArray r, ArrayElem r ~ w) => r -> ValidationDigest w
+instance ValidationDigestWord Word32 where
+  type ValidationDigest Word32 = MD5Digest
+  digest' = digest
+instance ValidationDigestWord Word64 where 
+  type ValidationDigest Word64 = Skein512Digest Word128
+  digest' = digest
+
+data RootValidator w = RootValidator deriving (Eq, Show)
+type Header w = (Len w Word, ValidationDigest w)
+instance (ValidationDigestWord w, Show (ValidationDigest w)) => Validator (RootValidator w) where
+  type ValidatedElem (RootValidator w) = w
+  mkValidationInput b = (RootValidator, [serializeToArray persister ((arrayLen b, digest' b) :: Header w), b])
+  validate RootValidator b = 
+    let DeserOut ((len, h) :: Header w) u = deserializeFromArray (unsafeSeqDeserializer persister) b
+        payload = headArrayRange len $ skipArrayRange (coarsenLen u) b
+    in payload `justIf` (digest' payload == h)
+
+instance Persistent (RootValidator w) where persister = structureMap persister
+
+deriveStructured ''RootValidator
+ src/Database/Perdure/SingleStoreFile.hs view
@@ -0,0 +1,30 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, Rank2Types, GADTs, TupleSections, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+
+module Database.Perdure.SingleStoreFile (
+    SingleStoreFile(..)
+  ) where
+       
+import Database.Perdure.StoreFile
+import Database.Perdure.LocalStoreFile
+import Cgm.Data.Word
+
+
+newtype SingleStoreFile a = SingleStoreFile a deriving SyncableStoreFile
+instance RawStoreFile a => StoreFile (SingleStoreFile a) where
+  type StoreRef (SingleStoreFile a) = BasicRef
+  storeFileWrite (SingleStoreFile f) addr e bufs = storeFileWrite1 f addr e bufs >> return (BasicRef addr $ narrowBufsLen bufs)
+  storeFileRead (SingleStoreFile f) (BasicRef addr size) = storeFileRead1 f addr size
+
+ src/Database/Perdure/SizeRef.hs view
@@ -0,0 +1,48 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TemplateHaskell, TypeFamilies, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, StandaloneDeriving #-}
+
+module Database.Perdure.SizeRef (
+  SizeRef
+  ) where
+
+import Data.Bits
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Database.Perdure.Persistent
+import Cgm.Data.Functor.Sum
+import Database.Perdure.DRef
+import Database.Perdure.Allocator
+import Database.Perdure.StoreFile
+import Cgm.Data.Nat
+import Data.Dynamic
+
+-- | A reference type which automatically puts its referent is a separately loadable allocation when that
+-- allocation's size is greater than 2^n bytes.
+data SizeRef n a = TooSmallForRef !a  | LargeEnoughForRef !(DRef a) deriving Typeable
+deriving instance Show a => Show (SizeRef n a)
+
+instance Persistent1 (SizeRef n) where persister1 = structureMap $ persister |. persister1
+instance Nat n => RefPersistent (SizeRef n) where
+  refPersister = RefView (either (TooSmallForRef . deref) LargeEnoughForRef . getSum) $ 
+                 SizeRefPersister $ refineLen l where
+    l :: Len Word8 Word
+    l = unsafeLen $ 1 `shiftL` (at :: At n) intOfNat
+  -- The use of the SizeRef constructor above instead of struct is required because the Structure typeclass seems
+  -- only able to dispatch on monotypes
+  -- Also the type annotation is necessary, and it seems to be because we are using the InjectionA typeclass, with no functional dependencies between
+  -- the related types. 
+instance Deref (SizeRef n) where derefIO = either return derefIO . structure
+
+deriveStructured ''SizeRef
+ src/Database/Perdure/Space.hs view
@@ -0,0 +1,36 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+module Database.Perdure.Space (
+  Space(..),
+  Span,
+  module Cgm.Data.SortedPair,
+  module Data.Monoid
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Data.Monoid
+import Data.Word
+import Cgm.Data.SortedPair
+
+type Span = SortedPair Word64
+
+-- Users must ensure they do not add overlapping spans, or remove spans unless all of its contents has already been added (perhaps as seperate spans)
+class Space a where
+  emptySpace :: a
+  removeSpan :: Span -> a -> a
+  addSpan :: Span -> a -> a
+  findSpan :: Word64 -> a -> [Span]
+  isFreeSpace :: Word64 -> a -> Bool
+
+ src/Database/Perdure/SpaceBook.hs view
@@ -0,0 +1,44 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, FlexibleContexts, UndecidableInstances, TypeFamilies, DeriveDataTypeable #-}
+
+module Database.Perdure.SpaceBook(
+  SpaceBook(..)
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Structured
+import Control.Monad.State
+import Database.Perdure.Persistent
+import Database.Perdure.Space
+import Database.Perdure.SpaceTree
+import Database.Perdure.Count
+import Database.Perdure.Data.MapMultiset
+import Database.Perdure.CSerializer(Address)
+import Cgm.Data.Monoid
+import Database.Perdure.ReplicatedFile
+import Debug.Trace
+import Cgm.Data.Super
+import Database.Perdure.Package
+import Cgm.Data.Typeable
+
+data SpaceBook = SpaceBook {
+  bookCount :: !(MapMultiset Address), 
+  bookSpace :: !SpaceTree
+  } deriving Typeable
+
+instance Persistent SpaceBook where persister = structureMap persister
+                                        
+deriveStructured ''SpaceBook
+ src/Database/Perdure/SpaceTree.hs view
@@ -0,0 +1,64 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TypeFamilies, TemplateHaskell, DeriveDataTypeable #-}
+
+module Database.Perdure.SpaceTree(
+  SpaceTree
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Data.Word
+import Cgm.Data.Maybe
+import Cgm.Control.Monad.State
+import Database.Perdure.Space
+import Database.Perdure.Data.Map
+import Database.Perdure.Persistent
+import Debug.Trace
+import Data.Typeable
+
+newtype SpaceTree = SpaceTree (Map Word64 Bool) deriving Typeable
+instance Space SpaceTree where
+  emptySpace = SpaceTree Database.Perdure.Data.Map.empty
+  removeSpan = onSortedPair (\b e -> spaceTreeIncr e . spaceTreeDecr b)
+  addSpan = onSortedPair (\b e -> spaceTreeIncr b . spaceTreeDecr e)
+  findSpan sz (SpaceTree m) = filter (onSortedPair $ \start end -> end - start > sz) $
+    let
+      start = 0 -- TODO pass that in as a parameter
+      mkSpans [] = []
+      mkSpans (k : []) = error "bad SpaceTree"
+      mkSpans (k0 : k1 : ks) = unsafeSortedPair k0 k1 : mkSpans ks
+    in mkSpans $
+       (\(b, ks) -> bool (start : ks) ks b) $ -- When bool is false, prepend 'start' (consider that the span possibly overlapping 'start' actually starts at 'start')
+       ($ (True, [])) $
+       fromMaybe (const (True, [])) $
+       scan (\k -> bool (\_ -> id) (\b (_, ks) -> (b, k : ks)) $ k > start) 
+       (\k l r -> bool (l . r) r $ k <= start) m
+    -- scan's z is of type (Bool, [Address]) -> (Bool, [Address]) where the Bool is the value of the first key in the list (undefined when empty). 
+    -- Only keys > a are kept. The function prepends address, and only checks the input Bool when it has nothing to prepend.
+    -- relies on the invariant where values alternate between True and False as scan keys in ascending or descending order
+  isFreeSpace a (SpaceTree m) = fromMaybe False $ fromMaybe Nothing $ 
+                                scan (\k -> bool (const Nothing) Just $ k <= a) (\k -> bool (\l r -> maybe l Just r) const $ k >= a) m
+    -- scan's z is of type Maybe Bool and is Just the value associated to the largest key <= a, or Nothing there is no such key, cool use of lazyness
+
+spaceTreeIncr :: Word64 -> SpaceTree -> SpaceTree
+spaceTreeIncr a (SpaceTree m) = 
+  SpaceTree $ fromMaybe m $ snd $ runState (updateM a $ get >>= maybe (put (Just True)) (bool (put Nothing) (error $ "spaceTreeIncr " ++ show a))) m
+spaceTreeDecr :: Word64 -> SpaceTree -> SpaceTree
+spaceTreeDecr a (SpaceTree m) = 
+  SpaceTree $ fromMaybe m $ snd $ runState (updateM a $ get >>= maybe (put (Just False)) (bool (error $ "spaceTreeDecr " ++ show a) (put Nothing))) m
+
+instance Persistent SpaceTree where persister = structureMap persister
+
+deriveStructured ''SpaceTree
+ src/Database/Perdure/State.hs view
@@ -0,0 +1,280 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
+
+module Database.Perdure.State(
+  PState(stateLocation, stateSpace, stateRoot),
+  --initStateN,
+  Root(..),
+  RootValues(..),
+  rootAllocSize,
+  initState,
+  readState,
+  writeState,
+  --asyncWriteState,
+  updateState,
+  updateStateRead,
+  --asyncCollectState,
+  collectState,
+  collectStateM,
+  emptyCache,
+  module Database.Perdure.Space,
+  module Database.Perdure.Persistent,
+  CachedFile(..),
+  RootLocation(..),
+  RootAddress(..),
+  stateValue
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Control.Concurrent
+import qualified Cgm.Control.Monad.State as M
+import Control.Monad.State hiding (sequence)
+import Control.Monad.Reader hiding (sequence)
+import Control.Applicative
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Data.Ord
+import Data.Functor.Constant
+import Data.Functor.Identity
+import Cgm.System.Mem.Alloc
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Cgm.Data.List
+import Database.Perdure.Persistent
+import Database.Perdure.CSerializer
+import Database.Perdure.Decrementer
+import Database.Perdure.Incrementer
+import Database.Perdure.RootValidator
+import Database.Perdure.SizeRef
+import Database.Perdure.Space
+import Database.Perdure.SpaceTree
+import Database.Perdure.Count
+import Database.Perdure.Data.MapMultiset
+import Cgm.System.Endian
+import Cgm.Control.Combinators
+import Cgm.Control.Concurrent.MVar
+import Cgm.Control.Concurrent.Await
+import Cgm.Data.Monoid
+import Control.Arrow
+import Cgm.Data.Multiset as MS
+import Debug.Trace
+import Database.Perdure.Ref
+import Database.Perdure.SpaceBook
+import Database.Perdure.Package
+import Cgm.Data.Typeable
+import qualified Data.Cache.LRU as LRU
+import Cgm.Data.Maybe
+import Database.Perdure.WriteBits
+import Database.Perdure.AllocCopy
+import Cgm.Data.Super
+import Database.Perdure.Allocator
+import Database.Perdure.Rev
+
+moduleName :: String
+moduleName = "Database.Perdure.State"
+
+data CachedFile = CachedFile ReplicatedFile (MVar Cache)
+
+-- | The RootLocation specifies where roots are written, and provides a cache.
+data RootLocation = RootLocation CachedFile [RootAddress]
+
+-- | A number which is incremented every time a state is written.
+newtype StateId = StateId Word64 deriving (Ord, Eq, Show, Enum, Bounded, Persistent, Num, Real, Integral)
+
+newtype RootAddress = RootAddress {getRootAddress :: Address} deriving (Eq, Show)
+rootRef :: LgMultiple Word64 w => RootAddress -> BasicRef w
+rootRef (RootAddress a) = BasicRef a $ refineLen rootAllocSize
+
+-- | The PState represents the whole state of the database. It is needed to perform updates.
+data PState a = PState {
+  stateLocation :: RootLocation,
+  stateSpace :: SpaceTree,
+  -- ^ stateSpace is always a subset of (or the same as) the true free space as determined by scanning rootScan from rootScan's s and c
+  -- This subset is maintained conservatively to speed up new allocations.
+  stateRoot :: RootVersions a -- ^ The persisted data consisting of bookkeeping data and user data.
+  }
+
+stateValue :: PState a -> a
+stateValue = deref . rootValue . rootScan . toOnlyRev . stateRoot
+
+-- LATER For now a root occupies a constant space (an id and 4 DRefs). It would be preferable to
+-- not use a CDRef of a but a SizeRef that would allow us to write more data in the root (keeping in mind though that we need room
+-- for 2 such references, after we have deducted the space for the id and the other two DRefs).
+-- | Root persisted data. The 'a' type parameter is the user persisted data type.
+data Root a = Root {
+  rootId :: StateId, 
+  rootDecr :: Maybe (RootValues a),
+  rootScan :: RootValues a
+  }
+
+type RootVersions a = Root a :> NoRev
+
+instance (Persistent a, Typeable a) => Persistent (Root a) where persister = structureMap persister
+
+data RootValues a = RootValues {
+  rootCS :: CDRef SpaceBook, 
+  rootValue :: CDRef a
+  }
+
+instance (Persistent a, Typeable a) => Persistent (RootValues a) where 
+  persister = structureMap persister
+
+-- | Writes an initial state (creates a new database).
+-- Most often the passed 'a' will be a fresh unpersisted value. This is always safe.
+-- However it is legal for parts of 'a' to be already persisted, but they must only use allocations within the passed SpaceTree.
+-- To read the state of an existing database use readState.
+initState :: (Persistent a, Typeable a) => RootLocation -> SpaceTree -> a -> IO (PState a)
+initState = initStateN minBound
+
+-- | The persisted value 'a' must only use memory contained in 'SpaceTree'.
+initStateN :: (Persistent a, Typeable a) => StateId -> RootLocation -> SpaceTree -> a -> IO (PState a)
+initStateN i l s a = 
+  let sb = SpaceBook MS.emptySet s
+      s' = bookSpace $ incr persister a sb -- Before we can write anything else, we need to know what memory is actually free.
+  in await0 $ writeRootSimple l s' $ Current $ Root i Nothing $ RootValues (ref sb) (ref a) 
+
+-- | Reads the state of an existing database. It only reads the root, and the rest is lazy loaded.
+-- The RootLocation must match the one use when writing. On failure it returns Nothing.
+readState :: (Persistent a, Typeable a) => RootLocation -> IO (Maybe (PState a))
+readState l@(RootLocation f rootAddrs) = 
+  fmap (\r -> let rs = rootScan $ toOnlyRev r in PState l (bookSpace $ incr persister rs $ deref $ rootCS rs) r) . 
+  maybeMaximumBy (comparing $ rootId . toOnlyRev) . catMaybes <$> sequence (readRoot f <$> rootAddrs)
+
+-- | Create an empty cache of the specified size (number of dereferenced DRefs).
+-- Note that eventually we would like a cache with a size measured in bytes, for a better prediction of memory consumption.
+emptyCache :: Integer -> Cache
+emptyCache sz = LRU.fromList (Just sz) []
+
+-- | We reserve the option of growing roots to 1MB, so use this as a minimum distance between the various RootAddress in RootLocation
+rootAllocSize :: Len Word64 Word32
+rootAllocSize = coarsenLen (unsafeLen (1024 * 1024) :: Len Word8 Word32)
+
+-- For now, asyncWriteState should be used synchronously (with await0) because we have no flow control on the StoreFile.
+asyncWriteState :: (Persistent a, Typeable a) => a -> PState a -> IO () -> IO (PState a)
+asyncWriteState a rs = 
+  (if rootId (toOnlyRev $ stateRoot rs) `mod` collectFrequency == 0 then \w k -> collectState rs >>= ($ k) . w else ($ rs)) $
+  \(PState l s rvers) -> case toOnlyRev rvers of (Root i d (RootValues rcs _)) ->
+                                                   writeRootSimple l s $ Current $ Root (succ i) d $ RootValues rcs $ ref a
+  
+collectFrequency :: StateId
+collectFrequency = 1000
+
+writeRootSimple :: forall a. (Persistent a, Typeable a) => RootLocation -> SpaceTree -> RootVersions a -> IO () -> IO (PState a)
+writeRootSimple l@(RootLocation f _) s r done = 
+  fmap (\(r', _ :: MapMultiset Address, s') -> PState l s' r') $ -- We may want to rewrite 'write' so it does not produce counts, and drop the Multiset c context
+  writeRoot (rootId $ toOnlyRev r) l done $ write f s r
+
+-- | Takes the current state and the new value to be written, and writes and returns a new state. Writing is strict so make sure you do
+-- not have cycles in the value to be written. After writing, you should no longer use the value you passed in, but instead use the
+-- equivalent value present in the in the returned state. That new equivalent value knows where it is stored and will be lazily loadable.
+-- The value just written will be partially or totally in the cache. IMPORTANT: This call overwrites the value that was in the state
+-- passed as input, so you should not use it after this call returns. However it is safe for this call to use it implicitly, because often
+-- the new value will be a function of the old one, and the strict write process will force parts of the old value to be read. If
+-- by accident you do use a value which was overwritten, its digests will be incorrect (with very high probability) and deref will return error.
+-- This calls collectState implicity once every 1000 calls. We will make this optional in future revisions.
+writeState :: (Persistent a, Typeable a) => a -> PState a  -> IO (PState a)
+writeState a r = await0 $ asyncWriteState a r
+
+-- | Writes a new state if the passed state change requires it. The StateT monad used here is like the usual StateT monad but
+-- it has an additional 'unchanged' case which allow us to avoid needless writes.
+updateState :: (Persistent a, Typeable a, MonadIO m) => M.StateT a m b -> M.StateT (PState a) m b
+updateState = updateStateRead . M.mapStateT lift
+
+-- | Like updateState but the updater has access to the input PState throught an additional ReaderT
+updateStateRead :: (Persistent a, Typeable a, MonadIO m) => M.StateT a (ReaderT (PState a) m) b -> M.StateT (PState a) m b
+updateStateRead (M.StateT u) = 
+  M.StateT $ \t -> runReaderT (u (deref $ rootValue $ rootScan $ toOnlyRev $ stateRoot t)) t 
+                   >>= \(b, ma') -> liftM (b,) $ maybe (return Nothing) (liftM Just . liftIO . flip writeState t) ma'
+
+-- collectState could overlap some of its work with normal writes. It could increment the latest state it sees when it starts, then decrement the old
+-- state, and finally do an atomic update of the state, rereading it to integreate any new states which have been added in the mean time. But we
+-- leave that for later.
+asyncCollectState :: (Persistent a, Typeable a) => PState a -> IO () -> IO (PState a)
+asyncCollectState (PState l _ rvers) done = -- we ignore s
+  let rcs'@(SpaceBook _ s') = incr persister d' $ deref rcs
+      (Root i md d'@(RootValues rcs ra)) = toOnlyRev rvers
+  in writeRootSimple l s' (Current $ Root (succ i) (Just d') $ RootValues (ref $ decr persister md rcs') ra) done
+     -- we write s'' but we do not use it, it will be used on next collectState
+     -- s'' contains memory we just freed. We cannot reuse it immediately in writing the new state in case we crash in the process.
+
+-- | Collects the garbage accumulated by the calls to writeState. Uses reference counting: first does an increment pass on
+-- the current value, and then does a decrement pass on the value that was present at the last collection. Only new allocations are
+-- scanned in the increment pass, not what was already allocated at the last collection. The decrement pass only traverses
+-- the allocations that need to be deallocated.
+collectState :: (Persistent a, Typeable a) => PState a -> IO (PState a)
+collectState r = await0 $ asyncCollectState r
+
+collectStateM :: (Persistent a, Typeable a) => M.StateT (PState a) IO ()
+collectStateM = get >>= lift . collectState >>= put
+
+---------------
+
+writeRoot :: StateId -> RootLocation -> IO () -> StateT (ABitSeq RealWorld) IO a -> IO a
+writeRoot i (RootLocation (CachedFile f _) roots) done writer = do
+  start <- stToIO mkABitSeq
+  (result, end) <- runStateT writer start
+  {-# SCC "barrier" #-} storeFileFullBarrier f -- If the following write completes, we want to assume that all preceeding writes completed
+  arr <- allocCopyBits start end
+  onWordConv (writeRoot' (apply wordConv1 arr :: PrimArray Pinned Word32)) (writeRoot' (apply wordConv1 arr :: PrimArray Pinned Word64))
+  -- We would like a full barrier here, to make sure reads do not move before matching writes, there is one just before,
+  -- and the precedeeing write is protected by the following sync (and will never be read)
+  {-# SCC "sync" #-} storeFileSync f done -- We need to know when the transaction has become durable
+  -- No barrier here, however that does not help much since we have a barrier before the preceeding write
+  return result where
+    writeRoot' :: forall w. (LgMultiple Word64 w, ValidationDigestWord w) => PrimArray Pinned w -> IO ()
+    writeRoot' arr = {-# SCC "writeRoot" #-} do
+      let (RootValidator, bufs) = mkValidationInput arr
+      when (sum (arrayLen <$> bufs) > apply super (refineLen rootAllocSize :: Len w Word32)) $ error "Root too large."
+      () <$ storeFileWrite f (getRootAddress $ genericIndex roots $ mod i $ fromIntegral $ length roots) platformWordEndianness bufs
+
+-- No need for barrier after write root. If the root writing is delayed
+-- past later writes which are starting to write the next state, we should already be garanteed that the new writes are not
+-- overwriting the allocations of the previous state, otherwise the system would not be resumable after a crash.
+
+write :: (Multiset c, Persistent a', Space ls) => 
+         CachedFile -> ls -> a' -> StateT (ABitSeq RealWorld) IO (a', c Address, ls)
+write (CachedFile f c) ls a' = {-# SCC "serialize" #-} StateT $ \s -> do
+  cd <- newMVar emptySet
+  lv <- newMVar ls
+  cSer persister (c, StateAllocator f lv, Just cd) (\a'' s' -> readMVar lv >>= \ls' -> readMVar cd >>= \u -> return ((a'', u, ls'), s')) a' s
+
+readRoot :: forall a d f. (Persistent a, Typeable a) => CachedFile -> RootAddress -> IO (Maybe (RootVersions a))
+readRoot (CachedFile f c) rootAddr =
+  fmap (deserializeFromFullArray $ apply cDeser persister $ DeserializerContext f c) <$> 
+  foldM (\result next -> maybe next (return . Just) result) Nothing readRootDataWE where
+    readRootData :: forall w. ValidationDigestWord w => Endianness -> Tagged w (IO (Maybe (ArrayRange (PrimArray Free Word))))
+    readRootData e = tag $ fmap (fmap deserInput) $ await1 $ 
+                     storeFileRead f (rootRef rootAddr) e (RootValidator :: RootValidator w)
+    readRootDataW e = onWordConv id reverse [(at :: At Word32) $ readRootData e, (at :: At Word64) $ readRootData e]
+    readRootDataWE = concat $ transpose $ readRootDataW <$> [platformWordEndianness, reverseEndianness platformWordEndianness]
+
+---------------
+
+data StateAllocator a = StateAllocator ReplicatedFile (MVar a)
+
+instance Space a => Allocator (StateAllocator a) where
+  allocatorStoreFile (StateAllocator f _) = f
+  alloc (StateAllocator _ var) len = modifyMVar var $ \a -> do
+    let span = requireSpan a
+    let a' = removeSpan span a
+    --putStrLn $ "Alloc " ++ show size ++ "@" ++ show (onSortedPair const span) ++ "  => free: " ++ (show a') --findSpan 0 a'
+    return (a', onSortedPair (\start end -> unsafeLen start) span) where
+      requireSpan = onSortedPair (\start _ -> unsafeSortedPair start (start + getLen len)) . 
+                    fromMaybe (error "Out of storage space") . listHead . 
+                    findSpan (getLen len)
+
+deriveStructured ''Root
+deriveStructured ''RootValues
+ src/Database/Perdure/StoreFile.hs view
@@ -0,0 +1,64 @@+{-+Copyright 2010-2012 Cognimeta Inc.++Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at++     http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software distributed under the License is+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express+or implied. See the License for the specific language governing permissions and limitations under the License.+-}++{-# LANGUAGE ExistentialQuantification, TypeFamilies, FlexibleContexts, TemplateHaskell, ScopedTypeVariables #-}++module Database.Perdure.StoreFile (+    StoreFile(..),+    SyncableStoreFile(..),+    await0,+    await1,+    refSpan,+    Word64,+    BasicRef(..),+    module Foreign.Ptr,+    module Cgm.Data.Len,+    module Validator+) where++import Prelude ()+import Cgm.Prelude+import Data.Word+import Data.ByteString+import Foreign.Ptr+import Cgm.Data.Len+import Cgm.Data.Super+import Cgm.Control.Concurrent.Await+import Database.Perdure.Validator as Validator+import Cgm.System.Endian+import Cgm.Data.Structured+import Database.Perdure.Space++class SyncableStoreFile f => StoreFile f where+  type StoreRef f :: * -> *+  -- | +  storeFileWrite :: Endian w => f -> Len Word64 Word64 -> Endianness -> [PrimArray Pinned w] -> IO (StoreRef f w)+  storeFileRead :: (Validator v, ValidatedElem v ~ w, Endian w, LgMultiple w Word8) => +                   f -> StoreRef f w -> Endianness -> v -> Async (Maybe (ArrayRange (PrimArray Pinned w))) ()+  +class SyncableStoreFile f where+  -- | Notify when all preceeding writes have completed, implies no barrier+  storeFileSync :: f -> IO () -> IO ()+  -- | Prevent the reordering of preceeding and subsequent read and write operations+  storeFileFullBarrier :: f -> IO ()+  +---------------------------------------------------------------------------+  +data BasicRef w = BasicRef {+    refStart :: {-# UNPACK #-} !(Len Word64 Word64),+    refSize :: {-# UNPACK #-} !(Len w Word32)}++refSpan :: forall w. LgMultiple Word64 w => BasicRef w -> Span+refSpan (BasicRef addr sz) = unsafeSortedPair (getLen addr) $ getLen $ (+ addr) $ coarsenLen (apply super sz :: Len w Word64)++deriveStructured ''BasicRef
+ src/Database/Perdure/Validator.hs view
@@ -0,0 +1,48 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, TupleSections #-}
+
+module Database.Perdure.Validator (
+  Validator(..),
+  Validator0(..),
+  module Cgm.Data.Array  
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Cgm.Data.Word
+import Cgm.Data.Array
+
+-- Although most hash functions are defined on strings of byte as a convention, they often start by converting the plaintext to strings
+-- of 32 or 64 bit words. They may do the reverse with the output. We will restrict ourselves to such hash functions (stripped of their
+-- intial and final byte conversions) so that we may apply them with equal efficiency, and identical results, on either big-endian or
+-- little-endian platforms. The buffers we hash are made up of 32bit or 64bit words. This also allows for a clean design where byte conversion
+-- (when needed due to the interoperation of systems of different endianness) occurs after hashing when writing, and before
+-- hashing when reading. We do not have readily available implementations of the hash functions with the byte conversion layer stripped, so
+-- we will use a (64-bit) hash function with a little endian byte-conversion layer (such as tiger of skein-512 from 
+-- http://hackage.haskell.org/package/cryptohash-0.6.2), and add an additional byte-swap layers when we are on big-endian machines.
+-- When we have time we can optimize big-endian machines by reworking the code of the library. For 32 bit platforms we will
+-- use a 32 bit optimized hash algorithm, with a digest of the same size. When reading we will need to know both the endianness
+-- in which the data was written, but also the word size (and thus the hash algorithm) of the written data.
+
+class Validator v where
+  type ValidatedElem v
+  mkValidationInput :: PrimArray Pinned (ValidatedElem v) -> (v, [PrimArray Pinned (ValidatedElem v)]) -- TODO generalize to ArrayRange
+  validate :: Prim (ValidatedElem v) => v -> ArrayRange (PrimArray Pinned (ValidatedElem v)) -> Maybe (ArrayRange (PrimArray Pinned (ValidatedElem v)))
+
+data Validator0 w = Validator0
+instance Validator (Validator0 w) where
+  type ValidatedElem (Validator0 w) = w
+  mkValidationInput = (Validator0, ) . pure
+  validate Validator0 = Just
+ src/Database/Perdure/WValidator.hs view
@@ -0,0 +1,47 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, TupleSections, ScopedTypeVariables, FlexibleInstances #-}
+
+module Database.Perdure.WValidator (
+  W32Validator,
+  W64Validator,
+  module Database.Perdure.Validator
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import Data.Word
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Database.Perdure.Digest
+import Database.Perdure.Validator
+import Cgm.System.Endian
+import Cgm.Data.Maybe
+import Cgm.Data.Structured
+
+data W32Validator = W32Validator {-# UNPACK #-} !MD5Digest deriving (Eq, Show)
+data W64Validator = W64Validator {-# UNPACK #-} !(Skein512Digest Word128) deriving (Eq, Show)
+
+instance Validator W32Validator where
+  type ValidatedElem W32Validator = Word32
+  mkValidationInput b = (W32Validator $ digest b, pure b)
+  validate (W32Validator h) b = b `justIf` (digest b == h)
+
+instance Validator W64Validator where
+  type ValidatedElem W64Validator = Word64
+  mkValidationInput b = (W64Validator $ digest b, pure b)
+  validate (W64Validator h) b = b `justIf` (digest b == h)
+
+deriveStructured ''W32Validator
+deriveStructured ''W64Validator
+ src/Database/Perdure/WordArrayRef.hs view
@@ -0,0 +1,43 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
+module Database.Perdure.WordArrayRef (
+  WordArrayRef(..)
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Cgm.Data.Word
+import Database.Perdure.ArrayRef
+import Database.Perdure.CDeserializer
+import Database.Perdure.Persistent
+
+-- | When we write Words and read them back on a platform with a different Word size, the array length changes,
+-- and each Word64 is replaced by two consecutive Words32 (least-significant first), (the reverse substitution is applied
+-- when going from Word32 to Word64, with an implicit 0 at the end when the size is odd)
+
+instance (ArrayRef r32, ArrayRef r64, ArrayRefElem r32 ~ Word32, ArrayRefElem r64 ~ Word64) => ArrayRef (WordArrayRef r32 r64) where
+  type ArrayRefElem (WordArrayRef r32 r64) = Word
+  writeArrayRef l b = onWordConv
+                      (Word32ArrayRef <$> writeArrayRef l (apply wordConv1 b)) 
+                      (Word64ArrayRef <$> writeArrayRef l (apply wordConv1 b))
+  derefArrayRef f (Word32ArrayRef r) = fmap deserInput <$> derefPinnedArrayRef f r
+  derefArrayRef f (Word64ArrayRef r) = fmap deserInput <$> derefPinnedArrayRef f r
+  arrayRefAddr (Word32ArrayRef r) = arrayRefAddr r
+  arrayRefAddr (Word64ArrayRef r) = arrayRefAddr r
+
+derefPinnedArrayRef :: (ArrayRef r, StoreFile f) => f -> r (StoreRef f) -> IO (Maybe (ArrayRange (PrimArray Pinned (ArrayRefElem r))))
+derefPinnedArrayRef = derefArrayRef
+
+ src/Database/Perdure/WordNArrayRef.hs view
@@ -0,0 +1,42 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
+module Database.Perdure.WordNArrayRef (
+  WordNArrayRef(..),
+  WordNValidator,
+  module Database.Perdure.ArrayRef
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Database.Perdure.ArrayRef
+import Database.Perdure.Persistent
+import Cgm.Data.Word
+import Cgm.System.Endian
+import Database.Perdure.WValidator
+
+class (Validator v, Persistent v, LgMultiple Word64 (ValidatedElem v), Endian (ValidatedElem v), LgMultiple (ValidatedElem v) Word8) => WordNValidator v
+instance WordNValidator W32Validator
+instance WordNValidator W64Validator
+
+instance WordNValidator v => ArrayRef (WordNArrayRef v) where
+  type ArrayRefElem (WordNArrayRef v) = ValidatedElem v
+  writeArrayRef l b = do
+    let (v, buf) = mkValidationInput b
+    r <- allocWrite l platformWordEndianness buf
+    return $ WordNArrayRef v r platformWordEndianness
+  derefArrayRef f (WordNArrayRef v r e) = fmap primArrayMatchAllocation <$> await1 (storeFileRead f r e v)
+  arrayRefAddr (WordNArrayRef _ r _) = refStart r
+
+ src/Database/Perdure/WriteBits.hs view
@@ -0,0 +1,221 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
+compliance with the License. You may obtain a copy of the License at
+
+     http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed under the License is
+distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
+or implied. See the License for the specific language governing permissions and limitations under the License.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, UnboxedTuples, BangPatterns, MagicHash, FlexibleInstances, TupleSections, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+
+-- Command line used to see simplified Core (from /src dir)
+-- ghc-7.0.1 -fforce-recomp  --make -O2 Cgm/Persist/WriteBits.hs -ddump-simpl -dppr-user-length=130 > b.hcr
+-- Notes on status: despite wordSeqAdd being inlined, the simplifier does not automatically create versions
+-- of writeBits functions that take the real-world, and return the real world as an additional element in the
+-- returned unboxed tuple. It still return an IO in the returned unboxed tuple. Will we need to do this manually ?
+-- Will subsequent optimization take care of that? Probably not since the IO monad is lazy.
+
+module Database.Perdure.WriteBits ( 
+  STSrcDest(..),
+  WordDest(..),
+  BitDest(..),
+  BitSrc(..),
+  WordSrc(..),
+  aligned,
+  padIncompleteWord,
+  WordSeq,
+  mkWordSeq,
+  CWordSeq(..),
+  BitAcc(..),
+  bitAccWordDest,
+  BSer,
+  ABitSeq,
+  mkABitSeq,
+  module Cgm.Data.Array
+  ) where
+
+import Debug.Trace
+import Foreign.Ptr
+import Data.Bits
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Identity
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Cgm.Data.Array
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Cgm.Data.WordN
+import Cgm.System.Mem.Alloc
+import Cgm.Control.Combinators
+
+
+------------------------- classes WordDest, BitDest, BitSrc and WordSrc -------------------------
+
+class STSrcDest d where
+  type SrcDestState d
+type SrcDestST d = ST (SrcDestState d)
+  
+class STSrcDest d => WordDest d where
+  addWord :: Word -> d -> SrcDestST d d
+
+class WordDest d => BitDest d where
+  addBit :: Word -> d -> SrcDestST d d -- 0 <= w <= 1
+  addBits :: Len Bool Word -> Word -> d -> SrcDestST d d -- 0 <= n <= wordBits, w < 2^n
+
+class STSrcDest d => BitSrc d where
+  addedBits :: d -> d -> Len Bool Word
+  copyBits :: (BitDest d', SrcDestST d ~ SrcDestST d') => d -> d -> d' -> SrcDestST d d'
+              -- ^ Copies all bits between an end and a start (of type d) to a destination
+
+class BitSrc d => WordSrc d where
+  addedWords :: d -> d -> Len Word Word
+  copyWords :: (WordDest d', SrcDestST d ~ SrcDestST d') => d -> d -> d' -> SrcDestST d d' 
+               -- ^ Copies all words between an end and a start (of type d) to a destination
+  copyWordsPartial :: (BitDest d', SrcDestST d ~ SrcDestST d') => d -> d -> Len Bool Word -> d' -> SrcDestST d d' 
+                      -- ^ Like copyWords, but excludes some lower bits [0, wordSize[ from the first Word
+  
+------------------------- Ptr -------------------------
+
+instance STSrcDest (Ptr Word) where type SrcDestState (Ptr Word) = RealWorld
+instance WordDest (Ptr Word) where
+  {-# INLINE addWord #-}
+  addWord w ptr = ioToST $ advancePtr ptr 1 <$ poke ptr w
+instance BitSrc (Ptr Word) where
+  addedBits = refineLen ./ addedWords
+  copyBits = copyWords
+instance WordSrc (Ptr Word) where
+  addedWords = (apply unsigned <$>) ./ minusPtrLen
+  copyWords end start d = if end == start then return d else ioToST (peek start) >>= \w -> addWord w d >>= copyWords end (start `advancePtrLen` 1)
+  copyWordsPartial end start dropLow = 
+    let len = addedWords end start 
+    in if len == 0
+       then undefined 
+       else (\d -> ioToST (peek start) >>= \w -> 
+              addBits (refineLen word - dropLow) (w `partialShiftRL` getLen dropLow) d) >=> copyWords end (start `advancePtrLen` 1)
+
+------------------------- WordSeq -------------------------
+
+-- With WordSeq we allocate memory as we go, so we do not need a size bound ahead of time.
+-- Here the least significant bits of the words are bits that were added before.
+-- 0 <= index < chunkSize
+data WordSeq s f = WordSeq !(Len Word Word, [STPrimArray s f Word]) {-# UNPACK #-} !(CWordSeq s f)
+
+chunkSize :: Len Word Word
+chunkSize = unsafeLen 2048
+
+{-# INLINE pushAnyFullChunk #-}
+pushAnyFullChunk :: STMkArray (STPrimArray s f Word) => WordSeq s f -> ST s (WordSeq s f)
+pushAnyFullChunk s@(WordSeq (l, r) (CWordSeq a ix)) = 
+  if ix < chunkSize then return s else WordSeq (l + chunkSize, a : r) . (`CWordSeq` 0) <$> mkArray chunkSize
+                                                                                 
+mkWordSeq :: STMkArray (STPrimArray s f Word) => ST s (WordSeq s f)
+mkWordSeq = WordSeq (0, []) . (`CWordSeq` 0) <$> mkArray chunkSize
+
+instance STSrcDest (WordSeq s f) where type SrcDestState (WordSeq s f) = s
+instance STMkArray (STPrimArray s f Word) => WordDest (WordSeq s f) where                          
+  {-# INLINE addWord #-}
+  addWord w (WordSeq r c) = (WordSeq r <$> addWord w c) >>= pushAnyFullChunk
+instance BitSrc (WordSeq s f) where
+  addedBits = refineLen ./ addedWords
+  copyBits = copyWords
+instance WordSrc (WordSeq s f) where
+  addedWords (WordSeq (s1, _) c1) (WordSeq (s0, _) c0) = addedWords c1 c0 + (s1 - s0)
+  copyWords (WordSeq (s1, r1) c1) start@(WordSeq (s0, _) c0) =
+    if s1 == s0
+    then copyWords c1 c0
+    else copyWords (WordSeq (s1 - chunkSize, tail r1) $ chunkEnd (head r1)) start >=> copyWords c1 (chunkStart c1)
+  copyWordsPartial (WordSeq (s1, r1) c1) start@(WordSeq (s0, _) c0) =
+    if s1 == s0
+    then copyWordsPartial c1 c0
+    else \drop -> copyWordsPartial (WordSeq (s1 - chunkSize, tail r1) $ chunkEnd (head r1)) start drop >=> copyWords c1 (chunkStart c1)
+ 
+chunkStart (CWordSeq a i) = CWordSeq a 0
+chunkEnd a = CWordSeq a chunkSize
+  
+------------------------- CWordSeq -------------------------
+
+-- Like WordSeq, but all words are contiguous, so the sequence cannot grow. No boundary check is performed. The initial allocation must be sufficient.
+data CWordSeq s f = CWordSeq {-# UNPACK #-} !(STPrimArray s f Word) {-# UNPACK #-} !(Len Word Word)
+
+instance STSrcDest (CWordSeq s f) where type SrcDestState (CWordSeq s f) = s
+instance WordDest (CWordSeq s f) where                          
+  {-# INLINE addWord #-}
+  addWord w (CWordSeq arr ix) = CWordSeq arr (ix + 1) <$ writeArray arr ix w
+instance BitSrc (CWordSeq s f) where
+  addedBits = refineLen ./ addedWords
+  copyBits = copyWords
+instance WordSrc (CWordSeq s f) where
+  addedWords (CWordSeq _ n1) (CWordSeq _ n0) = n1 - n0
+  copyWords end@(CWordSeq a i1) (CWordSeq _ i0) d =
+    if i1 == i0 then return d else readArray a i0 >>= flip addWord d >>= copyWords end (CWordSeq a $ i0 + 1)
+  copyWordsPartial end@(CWordSeq a i1) (CWordSeq _ i0) dropLow d =
+    if i1 == i0 then undefined 
+    else do 
+      w <- readArray a i0
+      addBits (refineLen word - dropLow) (w `partialShiftRL` getLen dropLow) d >>= copyWords end (CWordSeq a $ i0 + 1)
+ 
+------------------------- BitAcc -------------------------
+
+-- Invariant : 0 <= b < wordBits, w < 2^b
+data BitAcc d = BitAcc {-# UNPACK #-} !Word {-# UNPACK #-} !Word d
+
+type BSer d = BitAcc d -> SrcDestST (BitAcc d) (BitAcc d)
+
+{-# INLINE onAlignment #-}
+onAlignment :: (d -> z) -> (BitAcc d -> z) -> BitAcc d -> z
+onAlignment a u bd@(BitAcc b _ d) = if b == 0 then a d else u bd
+
+aligned :: d -> BitAcc d
+aligned = BitAcc 0 0
+
+bitAccWordDest :: BitAcc d -> d
+bitAccWordDest (BitAcc _ _ d) = d
+
+padIncompleteWord :: WordDest d => BitAcc d -> SrcDestST d d
+padIncompleteWord = onAlignment return (\(BitAcc _ acc d) -> addWord acc d)
+
+instance STSrcDest d => STSrcDest (BitAcc d) where type SrcDestState (BitAcc d) = SrcDestState d
+instance WordDest d => WordDest (BitAcc d) where
+  {-# SPECIALIZE INLINE addWord :: Word -> BSer (WordSeq RealWorld Free) #-}  
+  {-# SPECIALIZE INLINE addWord :: Word -> BSer (Ptr Word) #-}
+  addWord !w (BitAcc b acc d) = BitAcc b (if b == 0 then 0 else partialShiftRL w (wordBits - b)) <$> addWord (acc + partialShiftL w b) d
+
+instance WordDest d => BitDest (BitAcc d) where
+  {-# SPECIALIZE INLINE addBits :: Len Bool Word -> Word -> BSer (WordSeq s Free) #-}  
+  {-# SPECIALIZE INLINE addBits :: Len Bool Word -> Word -> BSer (Ptr Word) #-}  
+  addBits n !w (BitAcc b acc d) = let 
+    !acc' = acc + partialShiftL w b
+    b' = b + getLen n
+    b'' = b' - wordBits
+    in if (signed $* b'') < 0
+       then return $ BitAcc b' acc' d
+       else let 
+         !fullShift = getLen n == wordBits && b == 0
+         in if fullShift then aligned <$> addWord acc' d else BitAcc b'' (partialShiftRL w (getLen n - b'')) <$> addWord acc' d
+  {-# SPECIALIZE INLINE addBit :: Word -> BSer (WordSeq s Free) #-}  
+  {-# SPECIALIZE INLINE addBit :: Word -> BSer (Ptr Word) #-}  
+  addBit !w (BitAcc b acc d) = let 
+    acc' = acc + partialShiftL w b
+    b' = b + 1
+    b'' = b' - wordBits
+    in if (signed $* b'') < 0
+       then return $ BitAcc b' acc' d
+       else aligned <$> addWord acc' d
+instance WordSrc d => BitSrc (BitAcc d) where
+  copyBits (BitAcc endB endAcc end) (BitAcc startB _ start) =
+    if addedWords end start == 0
+    then addBits (unsafeLen $ endB - startB) (endAcc `partialShiftRL` startB)
+    else copyWordsPartial end start (unsafeLen startB) >=> addBits (unsafeLen endB) endAcc
+  addedBits (BitAcc b1 _ d1) (BitAcc b0 _ d0) = refineLen (addedWords d1 d0) + unsafeLen (b1 - b0)
+
+
+type ABitSeq s = BitAcc (WordSeq s Free)
+mkABitSeq :: ST s (ABitSeq s)
+mkABitSeq = aligned <$> mkWordSeq