structs (empty) → 0
raw patch · 15 files changed
+1385/−0 lines, 15 filesdep +basedep +deepseqdep +directorybuild-type:Customsetup-changed
Dependencies added: base, deepseq, directory, doctest, filepath, ghc-prim, hlint, parallel, primitive
Files
- CHANGELOG.markdown +3/−0
- LICENSE +26/−0
- README.markdown +24/−0
- Setup.lhs +46/−0
- src/Data/Struct.hs +35/−0
- src/Data/Struct/Internal.hs +207/−0
- src/Data/Struct/Internal/Label.hs +221/−0
- src/Data/Struct/Internal/LinkCut.hs +384/−0
- src/Data/Struct/Internal/Order.hs +180/−0
- src/Data/Struct/Label.hs +23/−0
- src/Data/Struct/LinkCut.hs +30/−0
- src/Data/Struct/Order.hs +18/−0
- structs.cabal +87/−0
- tests/doctests.hsc +78/−0
- tests/hlint.hs +23/−0
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+## 0+* Repository initialized+* Added structures for list labeling, order-maintenance, and link-cut trees.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,24 @@+structs+==========++[](http://travis-ci.org/ekmett/structs)++This package explores strict mutable data structures in Haskell. ++In particular, pointer-based data structures are effectively 'half price' due to the encoding used.++However, the result is that if you use the `slot` and `field` system wrong, you can and will `SEGFAULT`.++This means the `Internal` modules are very much internal.++Some documentation is available at+[http://ekmett.github.io/structs/Data-Struct.html](http://ekmett.github.io/structs/Data-Struct.html).++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ Setup.lhs view
@@ -0,0 +1,46 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ , postHaddock = \args flags pkg lbi ->+ postHaddock simpleUserHooks args flags pkg lbi+ }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
+ src/Data/Struct.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Unsafe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct+ ( Struct(..)+ , Object+ , destruct+ , construct+ , eqStruct+ , alloc+ -- * Nil+#ifndef HLINT+ , pattern Nil+#endif+ , isNil+ , NullPointerException(..)+ -- * Slots and Fields+ , Slot, slot+ , get, set+ , Field, field+ , unboxedField+ , getField, setField+ , Precomposable(..)+ ) where++import Data.Struct.Internal
+ src/Data/Struct/Internal.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------++module Data.Struct.Internal where++import Control.Exception+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Primitive+import Data.Coerce+import GHC.Exts+import GHC.ST++#ifdef HLINT+{-# ANN module "HLint: ignore Eta reduce" #-}+{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}+#endif++data NullPointerException = NullPointerException deriving (Show, Exception)++-- | A 'Dict' reifies an instance of the constraint @p@ into a value.+data Dict p where+ Dict :: p => Dict p++-- | Run an ST calculation inside of a PrimMonad. This lets us avoid dispatching everything through the 'PrimMonad' dictionary.+st :: PrimMonad m => ST (PrimState m) a -> m a+st (ST f) = primitive f+{-# INLINE[0] st #-}++{-# RULES "st/id" st = id #-}++-- | An instance for 'Struct' @t@ is a witness to the machine-level+-- equivalence of @t@ and @Object@. The argument to 'struct' is+-- ignored and is only present to help type inference.+class Struct t where+ struct :: proxy t -> Dict (Coercible (t s) (Object s))++data Object s = Object { runObject :: SmallMutableArray# s Any }++instance Struct Object where+ struct _ = Dict++-- TODO: get these to dispatch fast through 'coerce' using struct as a witness++destruct :: Struct t => t s -> SmallMutableArray# s Any+destruct = unsafeCoerce# runObject+{-# INLINE destruct #-}++construct :: Struct t => SmallMutableArray# s Any -> t s+construct = unsafeCoerce# Object+{-# INLINE construct #-}++unsafeCoerceStruct :: (Struct x, Struct y) => x s -> y s+unsafeCoerceStruct x = unsafeCoerce# x++eqStruct :: Struct t => t s -> t s -> Bool+eqStruct x y = isTrue# (destruct x `sameSmallMutableArray#` destruct y)+{-# INLINE eqStruct #-}++instance Eq (Object s) where+ (==) = eqStruct++-- instance Struct Object s where+-- construct = Object+-- destruct = runObject++#ifndef HLINT+pattern Struct :: () => Struct t => SmallMutableArray# s Any -> t s+pattern Struct x <- (destruct -> x) where+ Struct x = construct x+#endif++-- | Allocate a structure made out of `n` slots. Initialize the structure before proceeding!+alloc :: (PrimMonad m, Struct t) => Int -> m (t (PrimState m))+alloc (I# n#) = primitive $ \s -> case newSmallArray# n# undefined s of (# s', b #) -> (# s', construct b #)++--------------------------------------------------------------------------------+-- * Tony Hoare's billion dollar mistake+--------------------------------------------------------------------------------++data Box = Box !Null+data Null = Null++isNil :: Struct t => t s -> Bool+isNil t = isTrue# (unsafeCoerce# reallyUnsafePtrEquality# (destruct t) Null)+{-# INLINE isNil #-}++#ifndef HLINT+-- | Truly imperative.+pattern Nil :: forall t s. () => Struct t => t s+pattern Nil <- (isNil -> True) where+ Nil = unsafeCoerce# Box Null+#endif++--------------------------------------------------------------------------------+-- * Faking SmallMutableArrayArray#s+--------------------------------------------------------------------------------++writeSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> State# s -> State# s+writeSmallMutableArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s+{-# INLINE writeSmallMutableArraySmallArray# #-}++readSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, SmallMutableArray# s Any #)+readSmallMutableArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s+{-# INLINE readSmallMutableArraySmallArray# #-}++writeMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> MutableByteArray# s -> State# s -> State# s+writeMutableByteArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s+{-# INLINE writeMutableByteArraySmallArray# #-}++readMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, MutableByteArray# s #)+readMutableByteArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s+{-# INLINE readMutableByteArraySmallArray# #-}++--------------------------------------------------------------------------------+-- * Field Accessors+--------------------------------------------------------------------------------++-- | A 'Slot' is a reference to another unboxed mutable object.+data Slot x y = Slot+ (forall s. SmallMutableArray# s Any -> State# s -> (# State# s, SmallMutableArray# s Any #))+ (forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> State# s)++-- | We can compose slots to get a nested slot or field accessor+class Precomposable t where+ ( # ) :: Slot x y -> t y z -> t x z++instance Precomposable Slot where+ Slot gxy _ # Slot gyz syz = Slot+ (\x s -> case gxy x s of (# s', y #) -> gyz y s')+ (\x z s -> case gxy x s of (# s', y #) -> syz y z s')++-- | The 'Slot' at the given position in a 'Struct'+slot :: Int -> Slot s t+slot (I# i) = Slot+ (\m s -> readSmallMutableArraySmallArray# m i s)+ (\m a s -> writeSmallMutableArraySmallArray# m i a s)++-- | Get the value from a 'Slot'+get :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> m (y (PrimState m))+get (Slot go _) x = primitive $ \s -> case go (destruct x) s of+ (# s', y #) -> (# s', construct y #)+{-# INLINE get #-}++-- | Set the value of a 'Slot'+set :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()+set (Slot _ go) x y = primitive_ (go (destruct x) (destruct y))+{-# INLINE set #-}++-- | A 'Field' is a reference from a struct to a normal Haskell data type.+data Field x a = Field+ (forall s. SmallMutableArray# s Any -> State# s -> (# State# s, a #))+ (forall s. SmallMutableArray# s Any -> a -> State# s -> State# s)++instance Precomposable Field where+ Slot gxy _ # Field gyz syz = Field+ (\x s -> case gxy x s of (# s', y #) -> gyz y s')+ (\x z s -> case gxy x s of (# s', y #) -> syz y z s')++-- | Store the reference to the Haskell data type in a normal field+field :: Int -> Field s a+field (I# i) = Field+ (\m s -> unsafeCoerce# readSmallArray# m i s)+ (\m a s -> unsafeCoerce# writeSmallArray# m i a s)+{-# INLINE field #-}++-- | Store the reference in the nth slot of the nth argument, treated as a MutableByteArray+unboxedField :: Prim a => Int -> Int -> Field s a+unboxedField (I# i) (I# j) = Field+ (\m s -> case readMutableByteArraySmallArray# m i s of+ (# s', mba #) -> readByteArray# mba j s')+ (\m a s -> case readMutableByteArraySmallArray# m i s of+ (# s', mba #) -> writeByteArray# mba j a s')+{-# INLINE unboxedField #-}++-- | Get the value of a field in a struct+getField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> m a+getField (Field go _) x = primitive (go (destruct x))+{-# INLINE getField #-}++-- | Set the value of a field in a struct+setField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> a -> m ()+setField (Field _ go) x y = primitive_ (go (destruct x) y)+{-# INLINE setField #-}
+ src/Data/Struct/Internal/Label.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct.Internal.Label where++import Control.Exception+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Bits+import Data.Struct.Internal+import Data.Word++#ifdef HLINT+{-# ANN module "HLint: ignore Eta reduce" #-}+#endif++------------------------------------------------------------------------------------+-- * List Labeling: Maintain n keys each labeled with n^2 bits w/ log n update time.+--+-- After about 2^32 elements, this structure will continue to work, but will become+-- unacceptably slow and the asymptotic analysis will become wrong.+------------------------------------------------------------------------------------++type Key = Word64++midBound :: Key+midBound = unsafeShiftR maxBound 1++key :: Field Label Key+key = field 0+{-# INLINE key #-}++next :: Slot Label Label+next = slot 1+{-# INLINE next #-}++prev :: Slot Label Label+prev = slot 2+{-# INLINE prev #-}++-- | Logarithmic time list labeling solution+newtype Label s = Label (Object s)++instance Eq (Label s) where (==) = eqStruct++instance Struct Label where+ struct _ = Dict++-- | Construct an explicit list labeling structure.+--+-- >>> x <- makeLabel 0 Nil Nil+-- >>> isNil x+-- False+-- >>> n <- get next x+-- >>> isNil n+-- True+-- >>> p <- get prev x+-- >>> isNil p+-- True++makeLabel :: PrimMonad m => Key -> Label (PrimState m) -> Label (PrimState m) -> m (Label (PrimState m))+makeLabel a p n = st $ do+ this <- alloc 3+ setField key this a+ set next this n+ set prev this p+ return this+{-# INLINE makeLabel #-}++-- | O(1). Create a new labeling structure. Labels from different list labeling structures are incomparable.+new :: PrimMonad m => m (Label (PrimState m))+new = makeLabel midBound Nil Nil+{-# INLINE new #-}++-- | O(1). Remove a label+delete :: PrimMonad m => Label (PrimState m) -> m ()+delete this = st $ unless (isNil this) $ do+ p <- get prev this+ n <- get next this+ unless (isNil p) $ do+ set next p n+ set prev this Nil+ unless (isNil n) $ do+ set prev n p+ set next this Nil+{-# INLINE delete #-}++-- | O(log n) amortized. Insert a new label after a given label.+insertAfter :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))+insertAfter this = st $ do+ when (isNil this) $ throw NullPointerException+ v0 <- getField key this+ n <- get next this+ v1 <- if isNil n+ then return maxBound+ else getField key n+ fresh <- makeLabel (v0 + unsafeShiftR (v1 - v0) 1) this n+ set next this fresh+ unless (isNil n) $ set prev n fresh+ growRight this v0 n 2+ return fresh+ where+ growRight :: Label s -> Key -> Label s -> Word64 -> ST s ()+ growRight !n0 !_ Nil !j = growLeft n0 j+ growRight n0 v0 nj j = do+ vj <- getField key nj+ if vj-v0 < j*j+ then do+ nj' <- get next nj+ growRight n0 v0 nj' (j+1)+ else do+ n1 <- get next n0 -- start at the fresh node+ balance n1 v0 (delta (vj-v0) j) j -- it moves over++ growLeft :: Label s -> Word64 -> ST s ()+ growLeft !c !j = do+ p <- get prev c+ if isNil p+ then balance c 0 (delta maxBound j) j -- full rebuild+ else do+ vp <- getField key p+ p' <- get prev p+ let !j' = j+1+ if maxBound - vp < j'*j'+ then growLeft p' j'+ else balance c vp (delta (maxBound-vp) j') j'++ balance :: Label s -> Key -> Key -> Word64 -> ST s ()+ balance !_ !_ !_ 0 = return ()+ balance Nil _ _ _ = return () -- error "balanced past the end" -- return ()+ balance c v dv j = do+ let !v' = v + dv+ setField key c v'+ n <- get next c+ balance n v' dv (j-1)+{-# INLINE insertAfter #-}++-- | O(1). Split off all labels after the current label.+cutAfter :: PrimMonad m => Label (PrimState m) -> m ()+cutAfter this = st $ do+ when (isNil this) $ throw NullPointerException+ n <- get next this+ unless (isNil n) $ do+ set next this Nil+ set prev n Nil+{-# INLINE cutAfter #-}++-- | O(1). Split off all labels before the current label.+cutBefore :: PrimMonad m => Label (PrimState m) -> m ()+cutBefore this = st $ do+ when (isNil this) $ throw NullPointerException+ p <- get prev this+ unless (isNil p) $ do+ set next p Nil+ set prev this Nil+{-# INLINE cutBefore #-}++-- | O(n). Retrieve the least label+least :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))+least xs0+ | isNil xs0 = throw NullPointerException+ | otherwise = st $ go xs0 where+ go :: Label s -> ST s (Label s)+ go this = do+ p <- get prev this+ if isNil p+ then return this+ else go p+{-# INLINE least #-}++-- | O(n). Retrieve the greatest label+greatest :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m))+greatest xs0+ | isNil xs0 = throw NullPointerException+ | otherwise = st $ go xs0 where+ go :: Label s -> ST s (Label s)+ go this = do+ n <- get next this+ if isNil n+ then return this+ else go n+{-# INLINE greatest #-}++-- | O(1). Compare two labels for ordering.+compareM :: PrimMonad m => Label (PrimState m) -> Label (PrimState m) -> m Ordering+compareM i j+ | isNil i || isNil j = throw NullPointerException+ | otherwise = compare <$> getField key i <*> getField key j+{-# INLINE compareM #-}++delta :: Key -> Word64 -> Key+delta m j = max 1 $ quot m (j+1)+{-# INLINE delta #-}++-- | O(1). Extract the current value assignment for this label. Any label mutation, even on other labels in this label structure, may change this answer.+value :: PrimMonad m => Label (PrimState m) -> m Key+value this = getField key this+{-# INLINE value #-}++-- | O(n). Get the keys of every label from here to the right.+keys :: PrimMonad m => Label (PrimState m) -> m [Key]+keys this = st $+ if isNil this+ then return []+ else do+ x <- getField key this+ n <- get next this+ xs <- keys n+ return (x:xs)+{-# INLINE keys #-}
+ src/Data/Struct/Internal/LinkCut.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------++module Data.Struct.Internal.LinkCut where++import Control.Exception+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Struct.Internal++#ifdef HLINT+{-# ANN module "HLint: ignore Reduce duplication" #-}+{-# ANN module "HLint: ignore Redundant do" #-}+#endif++-- | Amortized Link-Cut trees via splay trees based on Tarjan's little book.+--+-- These support O(log n) operations for a lot of stuff.+--+-- The parameter `a` is an arbitrary user-supplied monoid that will be summarized+-- along the path to the root of the tree.+--+-- In this example the choice of 'Monoid' is 'String', so we can get a textual description of the path to the root.+--+-- >>> x <- new "x"+-- >>> y <- new "y"+-- >>> link x y -- now x is a child of y+-- >>> x == y+-- False+-- >>> connected x y+-- True+-- >>> z <- new "z"+-- >>> link z x -- now z is a child of y+-- >>> (y ==) <$> root z+-- True+-- >>> cost z+-- "yxz"+-- >>> w <- new "w"+-- >>> u <- new "u"+-- >>> v <- new "v"+-- >>> link u w+-- >>> link v z+-- >>> link w z+-- >>> cost u+-- "yxzwu"+-- >>> (y ==) <$> root v+-- True+-- >>> connected x v+-- True+-- >>> cut z+--+-- @+-- y+-- x z y+-- z ==> w v x+-- w v u+-- u+-- @+--+-- >>> connected x v+-- False+-- >>> cost u+-- "zwu"+-- >>> (z ==) <$> root v+-- True+newtype LinkCut a s = LinkCut (Object s)++instance Struct (LinkCut a) where+ struct _ = Dict++instance Eq (LinkCut a s) where+ (==) = eqStruct++path, parent, left, right :: Slot (LinkCut a) (LinkCut a)+path = slot 0+parent = slot 1+left = slot 2+right = slot 3++value, summary :: Field (LinkCut a) a+value = field 4+summary = field 5++-- | O(1). Allocate a new link-cut tree with a given monoidal summary.+new :: (PrimMonad m, Monoid a) => a -> m (LinkCut a (PrimState m))+new a = st $ do+ this <- alloc 6+ set path this Nil+ set parent this Nil+ set left this Nil+ set right this Nil+ setField value this a+ setField summary this a+ return this+{-# INLINE new #-}++-- | O(log n). @'cut' v@ removes the linkage between @v@ upwards to whatever tree it was in, making @v@ a root node.+--+-- Repeated calls on the same value without intermediate accesses are O(1).+cut :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m ()+cut this = st $ do+ access this+ l <- get left this+ unless (isNil l) $ do+ set left this Nil+ set parent l Nil+ v <- getField value this+ setField summary this v+{-# INLINE cut #-}++-- | O(log n). @'link' v w@ inserts @v@ which must be the root of a tree in as a child of @w@. @v@ and @w@ must not be 'connected'.+link :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> LinkCut a (PrimState m) -> m ()+link v w = st $ do+ -- w w<~v+ -- a , v => a+ --+ --+ access v+ access w+ set path v w+{-# INLINE link #-}++-- | O(log n). @'connected' v w@ determines if @v@ and @w@ inhabit the same tree.+connected :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> LinkCut a (PrimState m) -> m Bool+connected v w = st $ (==) <$> root v <*> root w+{-# INLINE connected #-}++-- | O(log n). @'cost' v@ computes the root-to-leaf path cost of @v@ under whatever 'Monoid' was built into the tree.+--+-- Repeated calls on the same value without intermediate accesses are O(1).+cost :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m a+cost v = st $ do+ access v+ getField summary v+{-# INLINE cost #-}++-- | O(log n). Find the root of a tree.+--+-- Repeated calls on the same value without intermediate accesses are O(1).+root :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m))+root this = st $ do+ access this+ r <- leftmost this+ splay r -- r is already in the root aux tree+ return r+ where+ leftmost v = do+ l <- get left v+ if isNil l then return v+ else leftmost l+{-# INLINE root #-}++-- | O(log n). Move upward one level.+--+-- This will return 'Nil' if the parent is not available.+--+-- Note: Repeated calls on the same value without intermediate accesses are O(1).+up :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m))+up this = st $ do+ access this+ a <- get left this+ if isNil a then return Nil+ else do+ p <- rightmost a+ splay p -- p is already in the root aux tree+ return p+ where+ rightmost v = do+ p <- get right v+ if isNil p then return v+ else rightmost p+{-# INLINE up #-}++-- | O(1)+summarize :: Monoid a => LinkCut a s -> ST s a+summarize this+ | isNil this = return mempty+ | otherwise = getField summary this+{-# INLINE summarize #-}++-- | O(log n)+access :: Monoid a => LinkCut a s -> ST s ()+access this = do+ when (isNil this) $ throw NullPointerException+ splay this+ -- the right hand child is no longer preferred+ r <- get right this+ unless (isNil r) $ do+ set right this Nil+ set parent r Nil+ set path r this+ -- resummarize+ l <- get left this+ sl <- summarize l+ v <- getField value this+ setField summary this (sl `mappend` v)+ go this+ splay this+ where+ go v = do+ w <- get path v+ unless (isNil w) $ do+ splay w+ -- w v w+ -- a b c d ==> a v, b.path = w+ -- c d+ b <- get right w+ unless (isNil b) $ do -- b is no longer on the preferred path+ set path b w+ set parent b Nil+ a <- get left w+ sa <- summarize a+ vw <- getField value w+ sv <- getField summary v+ set parent v w+ set right w v+ setField summary w (sa `mappend` vw `mappend` sv)+ go w++-- | O(log n). Splay within an auxiliary tree+splay :: Monoid a => LinkCut a s -> ST s ()+splay x = do+ p <- get parent x+ unless (isNil p) $ do+ g <- get parent p+ pl <- get left p+ if isNil g then do -- zig step+ set parent p x+ set parent x Nil+ pp <- get path p+ set path x pp+ set path p Nil+ sp <- getField summary p+ setField summary x sp+ if pl == x then do+ -- p x+ -- x d ==> b p+ -- b c c d+ c <- get right x+ d <- get right p+ unless (isNil c) $ set parent c p+ set right x p+ set left p c+ sc <- summarize c+ sd <- summarize d+ vp <- getField value p+ setField summary p (sc `mappend` vp `mappend` sd)+ else do+ -- p x+ -- a x ==> p c+ -- b c a b+ b <- get left x+ unless (isNil b) $ set parent b p+ let a = pl+ set left x p+ set right p b+ sa <- summarize a+ sb <- summarize b+ vp <- getField value p+ setField summary p (sa `mappend` vp `mappend` sb)+ else do -- zig-zig or zig-zag+ gg <- get parent g+ gl <- get left g+ sg <- getField summary g+ setField summary x sg+ set parent x gg+ gp <- get path g+ set path x gp+ set path g Nil+ if gl == p then do+ if pl == x then do -- zig-zig+ -- g x+ -- p d a p+ -- x c ==> b g+ -- a b c d+ b <- get right x+ c <- get right p+ d <- get right g+ set parent p x+ set parent g p+ unless (isNil b) $ set parent b p+ unless (isNil c) $ set parent c g+ set right x p+ set right p g+ set left p b+ set left g c+ sb <- summarize b+ vp <- getField value p+ sc <- summarize c+ vg <- getField value g+ sd <- summarize d+ let sg' = sc `mappend` vg `mappend` sd+ setField summary g sg'+ setField summary p (sb `mappend` vp `mappend` sg')+ else do -- zig-zag+ -- g x+ -- p d ==> p g+ -- a x a b c d+ -- b c+ let a = pl+ b <- get left x+ c <- get right x+ d <- get right g+ set parent p x+ set parent g x+ unless (isNil b) $ set parent b p+ unless (isNil c) $ set parent c g+ set left x p+ set right x g+ set right p b+ set left g c+ sa <- summarize a+ vp <- getField value p+ sb <- summarize b+ setField summary p (sa `mappend` vp `mappend` sb)+ sc <- summarize c+ vg <- getField value g+ sd <- summarize d+ setField summary g (sc `mappend` vg `mappend` sd)+ else if pl == x then do -- zig-zag+ -- g x+ -- a p g p+ -- x d ==> a b c d+ -- b c+ let a = gl+ b <- get left x+ c <- get right x+ d <- get right p+ set parent g x+ set parent p x+ unless (isNil b) $ set parent b g+ unless (isNil c) $ set parent c p+ set left x g+ set right x p+ set right g b+ set left p c+ sa <- summarize a+ vg <- getField value g+ sb <- summarize b+ setField summary g (sa `mappend` vg `mappend` sb)+ sc <- summarize c+ vp <- getField value p+ sd <- summarize d+ setField summary p (sc `mappend` vp `mappend` sd)+ else do -- zig-zig+ -- g x+ -- a p p d+ -- b x ==> g c+ -- c d a b+ let a = gl+ let b = pl+ c <- get left x+ unless (isNil b) $ set parent b g+ unless (isNil c) $ set parent c p+ set parent p x+ set parent g p+ set left x p+ set left p g+ set right g b+ set right p c+ sa <- summarize a+ vg <- getField value g+ sb <- summarize b+ vp <- getField value p+ sc <- summarize c+ let sg' = sa `mappend` vg `mappend` sb+ setField summary g sg'+ setField summary p (sg' `mappend` vp `mappend` sc)+ unless (isNil gg) $ do+ ggl <- get left gg+ -- NB: this replacement leaves the summary intact+ if ggl == g then set left gg x+ else set right gg x+ splay x
+ src/Data/Struct/Internal/Order.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_HADDOCK not-home #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct.Internal.Order where++import Control.Exception+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Bits+import Data.Struct.Internal+import Data.Struct.Internal.Label (Label, Key)+import qualified Data.Struct.Label as Label+import qualified Data.Struct.Internal.Label as Label (key)+import Data.Word++--------------------------------------------------------------------------------+-- * Order Maintenance+--------------------------------------------------------------------------------++-- | This structure maintains an order-maintenance structure as two levels of list-labeling.+--+-- The upper labeling scheme holds @(n / log w)@ elements in a universe of size @w^2@, operating in O(log n) amortized time per operation.+--+-- It is accelerated by an indirection structure where each smaller universe holds O(log w) elements, with total label space @2^log w = w@ and O(1) expected update cost, so we+-- can charge rebuilds to the upper structure to the lower structure.+--+-- Every insert to the upper structure is amortized across @O(log w)@ operations below.+--+-- This means that inserts are O(1) amortized, while comparisons remain O(1) worst-case.++newtype Order s = Order { runOrder :: Object s }++instance Eq (Order s) where (==) = eqStruct++instance Struct Order where+ struct _ = Dict++key :: Field Order Key+key = field 0+{-# INLINE key #-}++next :: Slot Order Order+next = slot 1+{-# INLINE next #-}++prev :: Slot Order Order+prev = slot 2+{-# INLINE prev #-}++parent :: Slot Order Label+parent = slot 3+{-# INLINE parent #-}++makeOrder :: PrimMonad m => Label (PrimState m) -> Key -> Order (PrimState m) -> Order (PrimState m) -> m (Order (PrimState m))+makeOrder mom a p n = st $ do+ this <- alloc 4+ set parent this mom+ setField key this a+ set prev this p+ set next this n+ return this+{-# INLINE makeOrder #-}++-- | O(1) compareM, O(1) amortized insert+compareM :: PrimMonad m => Order (PrimState m) -> Order (PrimState m) -> m Ordering+compareM i j+ | isNil i || isNil j = throw NullPointerException+ | otherwise = st $ do+ ui <- get parent i+ uj <- get parent j+ xs <- Label.compareM ui uj+ case xs of+ EQ -> compare <$> getField key i <*> getField key j+ x -> return x+{-# INLINE compareM #-}++insertAfter :: PrimMonad m => Order (PrimState m) -> m (Order (PrimState m))+insertAfter n0 = st $ do+ when (isNil n0) $ throw NullPointerException+ mom <- get parent n0+ k0 <- getField key n0+ n2 <- get next n0+ k2 <- if isNil n2 then return maxBound else getField key n2+ let !k1 = k0 + unsafeShiftR (k2 - k0) 1+ n1 <- makeOrder mom k1 n0 n2+ unless (isNil n2) $ set prev n2 n1+ set next n0 n1+ when (k0 + 1 == k2) $ rewind mom n0 -- we have a collision, rebalance+ return n1+ where+ -- find the smallest sibling+ rewind :: Label s -> Order s -> ST s ()+ rewind mom this = do+ p <- get prev this+ if isNil p then rebalance mom mom this 0 64+ else do+ dad <- get parent p+ if mom == dad then rewind mom p+ else rebalance mom mom p 0 64++ -- break up the family+ rebalance :: Label s -> Label s -> Order s -> Word64 -> Int -> ST s ()+ rebalance mom dad this k j = unless (isNil this) $ do+ guardian <- get parent this+ when (mom == guardian) $ do+ setField key this k+ set parent this dad+ n <- get next this+ if j > 0 then rebalance mom dad n (k + deltaU) (j-1)+ else do+ stepdad <- Label.insertAfter dad+ rebalance mom stepdad n deltaU logU++delete :: PrimMonad m => Order (PrimState m) -> m ()+delete this = st $ do+ when (isNil this) $ throw NullPointerException+ mom <- get parent this++ p <- get prev this+ n <- get next this++ set prev this Nil+ set next this Nil++ x <- if isNil p then return False+ else do+ set next p n+ pmom <- get parent p+ return (mom == pmom)++ y <- if isNil n then return False+ else do+ set prev n p+ nmom <- get parent n+ return (mom == nmom)++ unless (x || y) $ Label.delete mom+{-# INLINE delete #-}++logU :: Int+logU = 64++loglogU :: Int+loglogU = 6++deltaU :: Key+deltaU = unsafeShiftR maxBound loglogU -- U / log U++new :: PrimMonad m => m (Order (PrimState m))+new = st $ do+ l <- Label.new+ makeOrder l (unsafeShiftR maxBound 1) Nil Nil+{-# INLINE new #-}++value :: PrimMonad m => Order (PrimState m) -> m (Key, Key)+value this = st $ do+ mom <- get parent this+ (,) <$> getField Label.key mom <*> getField key this+{-# INLINE value #-}++-- O(n) sweep to the right from the current node, showing all values for debugging+values :: PrimMonad m => Order (PrimState m) -> m [(Key, Key)]+values xs0 = st (go xs0) where+ go :: Order s -> ST s [(Key, Key)]+ go this+ | isNil this = return []+ | otherwise = do+ n <- get next this+ (:) <$> value this <*> go n+{-# INLINE values #-}
+ src/Data/Struct/Label.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct.Label+ ( Label+ , new+ , insertAfter+ , delete+ , least+ , greatest+ , cutAfter+ , cutBefore+ , compareM+ ) where++import Data.Struct.Internal.Label
+ src/Data/Struct/LinkCut.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct.LinkCut+ ( LinkCut+ , new+ , link+ , cut+ , root+ , cost+ , parent+ , connected+ ) where++import Control.Monad.Primitive+import Data.Struct.Internal.LinkCut hiding (parent)++-- | O(log n). Find the parent of a node.+--+-- This will return 'Nil' if the parent does not exist.+--+-- Repeated calls on the same value without intermediate accesses are O(1).+parent :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m))+parent = up
+ src/Data/Struct/Order.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Data.Struct.Order+ ( Order+ , new+ , insertAfter+ , delete+ ) where++import Data.Struct.Internal.Order
+ structs.cabal view
@@ -0,0 +1,87 @@+name: structs+category: Data+version: 0+license: BSD3+cabal-version: >= 1.22+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/structs/+bug-reports: http://github.com/ekmett/structs/issues+copyright: Copyright (C) 2015 Edward A. Kmett+build-type: Custom+tested-with: GHC == 7.10.1, GHC == 7.10.2+synopsis: Strict GC'd imperative object-oriented programming with cheap pointers.+description:+ This project is an experiment with a small GC'd strict mutable imperative universe with cheap pointers inside of the GHC runtime system.++extra-source-files:+ CHANGELOG.markdown+ README.markdown++source-repository head+ type: git+ location: git://github.com/ekmett/structs.git++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+ default: True+ manual: True++-- You can disable the doctests test suite with -f-test-doctests+flag test-hlint+ default: True+ manual: True++library+ build-depends:+ base >= 4.8 && < 5,+ deepseq,+ ghc-prim,+ primitive++ exposed-modules:+ Data.Struct+ Data.Struct.Internal+ Data.Struct.Internal.Label+ Data.Struct.Internal.LinkCut+ Data.Struct.Internal.Order+ Data.Struct.Label+ Data.Struct.LinkCut+ Data.Struct.Order++ ghc-options: -Wall -fwarn-monomorphism-restriction -fwarn-identities -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -fno-warn-wrong-do-bind+ hs-source-dirs: src+ default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ default-language: Haskell2010++ if !flag(test-doctests)+ buildable: False+ else+ build-depends:+ base,+ directory >= 1.0,+ doctest >= 0.9.1,+ filepath,+ parallel++test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests+ default-language: Haskell2010++ if !flag(test-hlint)+ buildable: False+ else+ build-depends:+ base,+ hlint >= 1.7
+ tests/doctests.hsc view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : "-hide-all-packages"+#ifdef TRUSTWORTHY+ : "-DTRUSTWORTHY=1"+#endif+ : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ tests/hlint.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (hlint)+-- Copyright : (C) 2013-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure