diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.markdown
@@ -0,0 +1,3 @@
+## 0
+* Repository initialized
+* Added structures for list labeling, order-maintenance, and link-cut trees.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.markdown b/README.markdown
new file mode 100644
--- /dev/null
+++ b/README.markdown
@@ -0,0 +1,24 @@
+structs
+==========
+
+[![Build Status](https://secure.travis-ci.org/ekmett/structs.png?branch=master)](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
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -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}
diff --git a/src/Data/Struct.hs b/src/Data/Struct.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct.hs
@@ -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
diff --git a/src/Data/Struct/Internal.hs b/src/Data/Struct/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Internal.hs
@@ -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 #-}
diff --git a/src/Data/Struct/Internal/Label.hs b/src/Data/Struct/Internal/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Internal/Label.hs
@@ -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 #-}
diff --git a/src/Data/Struct/Internal/LinkCut.hs b/src/Data/Struct/Internal/LinkCut.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Internal/LinkCut.hs
@@ -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
diff --git a/src/Data/Struct/Internal/Order.hs b/src/Data/Struct/Internal/Order.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Internal/Order.hs
@@ -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 #-}
diff --git a/src/Data/Struct/Label.hs b/src/Data/Struct/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Label.hs
@@ -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
diff --git a/src/Data/Struct/LinkCut.hs b/src/Data/Struct/LinkCut.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/LinkCut.hs
@@ -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
diff --git a/src/Data/Struct/Order.hs b/src/Data/Struct/Order.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Struct/Order.hs
@@ -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
diff --git a/structs.cabal b/structs.cabal
new file mode 100644
--- /dev/null
+++ b/structs.cabal
@@ -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
diff --git a/tests/doctests.hsc b/tests/doctests.hsc
new file mode 100644
--- /dev/null
+++ b/tests/doctests.hsc
@@ -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
diff --git a/tests/hlint.hs b/tests/hlint.hs
new file mode 100644
--- /dev/null
+++ b/tests/hlint.hs
@@ -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