packages feed

structs 0 → 0.1

raw patch · 15 files changed

+608/−227 lines, 15 filesdep +template-haskelldep ~basesetup-changednew-uploader

Dependencies added: template-haskell

Dependency ranges changed: base

Files

CHANGELOG.markdown view
@@ -1,3 +1,13 @@+## 0.1+* Add compare-and-swap support for struct slots+* Add `Data.Struct.TH`, which provides Template Haskell support for+  generating structs+* Remove unneeded proxy argument to `struct`+* Add a type parameter to `Order`+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build+  with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and+  sandboxes.+ ## 0 * Repository initialized * Added structures for list labeling, order-maintenance, and link-cut trees.
+ HLint.hs view
@@ -0,0 +1,8 @@+import "hint" HLint.HLint++ignore "Reduce duplication"+ignore "Redundant lambda"+ignore "Use >=>"+ignore "Use const"+ignore "Use module export list"+ignore "Use newtype instead of data"
README.markdown view
@@ -1,9 +1,9 @@ structs ========== -[![Build Status](https://secure.travis-ci.org/ekmett/structs.png?branch=master)](http://travis-ci.org/ekmett/structs)+[![Hackage](https://img.shields.io/hackage/v/structs.svg)](https://hackage.haskell.org/package/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. +This package explores strict mutable data structures in Haskell.  In particular, pointer-based data structures are effectively 'half price' due to the encoding used.
Setup.lhs view
@@ -1,46 +1,34 @@-#!/usr/bin/runhaskell \begin{code}+{-# LANGUAGE CPP #-} {-# 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 ( (</>) )+#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif +#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests ) 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-  }+main = defaultMainWithDoctests "doctests" -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)+#else -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+import Warning ()+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif  \end{code}
+ Warning.hs view
@@ -0,0 +1,5 @@+module Warning+  {-# WARNING ["You are configuring this package without cabal-doctest installed.",+               "The doctests test-suite will not work as a result.",+               "To fix this, install cabal-doctest before configuring."] #-}+  () where
src/Data/Struct.hs view
@@ -28,7 +28,7 @@   , get, set   , Field, field   , unboxedField-  , getField, setField+  , getField, setField, modifyField, modifyField'   , Precomposable(..)   ) where
src/Data/Struct/Internal.hs view
@@ -4,19 +4,17 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2015 Edward Kmett+-- Copyright   :  (C) 2015-2017 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  experimental@@ -32,11 +30,15 @@ import Data.Primitive import Data.Coerce import GHC.Exts-import GHC.ST +-- $setup+-- >>> import Control.Monad.Primitive+ #ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}+{-# ANN module "HLint: ignore Avoid lambda" #-}+{-# ANN module "HLint: ignore Redundant lambda" #-} #endif  data NullPointerException = NullPointerException deriving (Show, Exception)@@ -47,48 +49,51 @@  -- | 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+st = primToPrim {-# 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.+--   equivalence of @t@ and @Object@. class Struct t where-  struct :: proxy t -> Dict (Coercible (t s) (Object s))+  struct :: Dict (Coercible (t s) (Object s))+#ifndef HLINT+  default struct :: Coercible (t s) (Object s) => Dict (Coercible (t s) (Object s))+#endif+  struct = Dict+  {-# MINIMAL #-}  data Object s = Object { runObject :: SmallMutableArray# s Any } -instance Struct Object where-  struct _ = Dict+instance Struct Object --- TODO: get these to dispatch fast through 'coerce' using struct as a witness+coerceF :: Dict (Coercible a b) -> a -> b+coerceF Dict = coerce+{-# INLINE coerceF #-} +coerceB :: Dict (Coercible a b) -> b -> a+coerceB Dict = coerce+{-# INLINE coerceB #-}+ destruct :: Struct t => t s -> SmallMutableArray# s Any-destruct = unsafeCoerce# runObject+destruct = \x -> runObject (coerceF struct x) {-# INLINE destruct #-}  construct :: Struct t => SmallMutableArray# s Any -> t s-construct = unsafeCoerce# Object+construct = \x -> coerceB struct (Object x) {-# INLINE construct #-}  unsafeCoerceStruct :: (Struct x, Struct y) => x s -> y s-unsafeCoerceStruct x = unsafeCoerce# x+unsafeCoerceStruct x = construct (destruct x)  eqStruct :: Struct t => t s -> t s -> Bool-eqStruct x y = isTrue# (destruct x `sameSmallMutableArray#` destruct y)+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 :: Struct t => () => SmallMutableArray# s Any -> t s pattern Struct x <- (destruct -> x) where   Struct x = construct x #endif@@ -101,16 +106,27 @@ -- * Tony Hoare's billion dollar mistake -------------------------------------------------------------------------------- -data Box = Box !Null+-- | Box is designed to mirror object's single field but using the 'Null' type+-- instead of a mutable array. This hack relies on GHC reusing the same 'Null'+-- data constructor for all occurrences. Box's field must not be strict to+-- prevent the compiler from making assumptions about its contents.+data Box = Box Null data Null = Null +-- | Predicate to check if a struct is 'Nil'.+--+-- >>> isNil (Nil :: Object (PrimState IO))+-- True+-- >>> o <- alloc 1 :: IO (Object (PrimState IO))+-- >>> isNil o+-- False 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 :: Struct t => () => t s pattern Nil <- (isNil -> True) where   Nil = unsafeCoerce# Box Null #endif@@ -135,6 +151,10 @@ readMutableByteArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s {-# INLINE readMutableByteArraySmallArray# #-} +casSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #)+casSmallMutableArraySmallArray# m i o n s = unsafeCoerce# casSmallArray# m i o n s+{-# INLINE casSmallMutableArraySmallArray# #-}+ -------------------------------------------------------------------------------- -- * Field Accessors --------------------------------------------------------------------------------@@ -143,52 +163,60 @@ 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)+  (forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #))  -- | 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+  Slot gxy _ _ # Slot gyz syz cyz = 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')+    (\x o n s -> case gxy x s of (# s', y #) -> cyz y o n s')  -- | The 'Slot' at the given position in a 'Struct'-slot :: Int -> Slot s t+slot :: Int {- ^ slot -} -> Slot s t slot (I# i) = Slot   (\m s -> readSmallMutableArraySmallArray# m i s)   (\m a s -> writeSmallMutableArraySmallArray# m i a s)+  (\m o n s -> casSmallMutableArraySmallArray# m i o n 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 #)+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))+set (Slot _ go _) = \x y -> primitive_ (go (destruct x) (destruct y)) {-# INLINE set #-} +-- | Compare-and-swap the value of the slot. Takes the expected old value, the new value and returns if it succeeded and the value found.+cas :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> y (PrimState m) -> m (Bool, y (PrimState m))+cas (Slot _ _ go) = \m o n -> primitive $ \s -> case go (destruct m) (destruct o) (destruct n) s of+  (# s', i, r #) -> (# s', (tagToEnum# i :: Bool, construct r) #)+ -- | 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)+  (forall s. SmallMutableArray# s Any -> State# s -> (# State# s, a #)) -- get+  (forall s. SmallMutableArray# s Any -> a -> State# s -> State# s) -- set  instance Precomposable Field where-  Slot gxy _ # Field gyz syz = Field+  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 :: Int {- ^ slot -} -> 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+-- | Store the reference in the nth slot in the nth argument, treated as a MutableByteArray+unboxedField :: Prim a => Int {- ^ slot -} -> Int {- ^ argument -} -> Field s a unboxedField (I# i) (I# j) = Field   (\m s -> case readMutableByteArraySmallArray# m i s of      (# s', mba #) -> readByteArray# mba j s')@@ -196,12 +224,41 @@      (# s', mba #) -> writeByteArray# mba j a s') {-# INLINE unboxedField #-} +-- | Initialized the mutable array used by 'unboxedField'. Returns the array+-- after storing it in the struct to help with initialization.+initializeUnboxedField ::+  (PrimMonad m, Struct x) =>+  Int             {- ^ slot     -} ->+  Int             {- ^ elements -} ->+  Int             {- ^ element size -} ->+  x (PrimState m) {- ^ struct   -} ->+  m (MutableByteArray (PrimState m))+initializeUnboxedField (I# i) (I# n) (I# z) m =+  primitive $ \s ->+    case newByteArray# (n *# z) s of+      (# s1, mba #) ->+        (# writeMutableByteArraySmallArray# (destruct m) i mba s1, MutableByteArray mba #)+{-# INLINE initializeUnboxedField #-}+ -- | 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))+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)+setField (Field _ go) = \x y -> primitive_ (go (destruct x) y) {-# INLINE setField #-}+++--------------------------------------------------------------------------------+-- * Modifiers+--------------------------------------------------------------------------------++modifyField :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m ()+modifyField s = \o f -> st (setField s o . f =<< getField s o)+{-# INLINE modifyField #-}++modifyField' :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m ()+modifyField' s = \o f -> st (setField s o =<< (\x -> return $! f x) =<< getField s o)+{-# INLINE modifyField' #-}
src/Data/Struct/Internal/Label.hs view
@@ -21,6 +21,9 @@ import Data.Struct.Internal import Data.Word +-- $setup+-- >>> import Data.Struct.Internal.Label+ #ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-} #endif@@ -54,8 +57,7 @@  instance Eq (Label s) where (==) = eqStruct -instance Struct Label where-  struct _ = Dict+instance Struct Label  -- | Construct an explicit list labeling structure. --
src/Data/Struct/Internal/LinkCut.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-monomorphism-restriction #-} ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2015 Edward Kmett+-- Copyright   :  (C) 2015-2017 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  experimental@@ -17,7 +20,11 @@ import Control.Monad.Primitive import Control.Monad.ST import Data.Struct.Internal+import Data.Struct.TH +-- $setup+-- >>> import Data.Struct.Internal.LinkCut+ #ifdef HLINT {-# ANN module "HLint: ignore Reduce duplication" #-} {-# ANN module "HLint: ignore Redundant do" #-}@@ -73,35 +80,16 @@ -- "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+makeStruct [d|+  data LinkCut a s = LinkCut+    { path, parent, left, right :: !(LinkCut a s)+    , value, summary :: a+    }+   |]  -- | 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+new :: PrimMonad m => a -> m (LinkCut a (PrimState m))+new a = st (newLinkCut Nil Nil Nil Nil a a) {-# INLINE new #-}  -- | O(log n). @'cut' v@ removes the linkage between @v@ upwards to whatever tree it was in, making @v@ a root node.
src/Data/Struct/Internal/Order.hs view
@@ -38,41 +38,45 @@ -- -- This means that inserts are O(1) amortized, while comparisons remain O(1) worst-case. -newtype Order s = Order { runOrder :: Object s }+newtype Order a s = Order { runOrder :: Object s } -instance Eq (Order s) where (==) = eqStruct+instance Eq (Order a s) where (==) = eqStruct -instance Struct Order where-  struct _ = Dict+instance Struct (Order a) -key :: Field Order Key+key :: Field (Order a) Key key = field 0 {-# INLINE key #-} -next :: Slot Order Order-next = slot 1+value :: Field (Order a) a+value = field 1+{-# INLINE value #-}++next :: Slot (Order a) (Order a)+next = slot 2 {-# INLINE next #-} -prev :: Slot Order Order-prev = slot 2+prev :: Slot (Order a) (Order a)+prev = slot 3 {-# INLINE prev #-} -parent :: Slot Order Label-parent = slot 3+parent :: Slot (Order a) Label +parent = slot 4 {-# 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+makeOrder :: PrimMonad m => Label (PrimState m) -> Key -> a -> Order a (PrimState m) -> Order a (PrimState m) -> m (Order a (PrimState m))+makeOrder mom a v p n = st $ do+  this <- alloc 5   set parent this mom   setField key this a+  setField value this v   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 :: PrimMonad m => Order a (PrimState m) -> Order a (PrimState m) -> m Ordering compareM i j   | isNil i || isNil j = throw NullPointerException   | otherwise = st $ do@@ -84,22 +88,22 @@     x -> return x {-# INLINE compareM #-} -insertAfter :: PrimMonad m => Order (PrimState m) -> m (Order (PrimState m))-insertAfter n0 = st $ do+insertAfter :: PrimMonad m => Order a (PrimState m) -> a -> m (Order a (PrimState m))+insertAfter n0 a1 = 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+  n1 <- makeOrder mom k1 a1 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 :: Label s -> Order a s -> ST s ()   rewind mom this = do     p <- get prev this     if isNil p then rebalance mom mom this 0 64@@ -109,7 +113,7 @@       else rebalance mom mom p 0 64    -- break up the family-  rebalance :: Label s -> Label s -> Order s -> Word64 -> Int -> ST s ()+  rebalance :: Label s -> Label s -> Order a s -> Word64 -> Int -> ST s ()   rebalance mom dad this k j = unless (isNil this) $ do     guardian <- get parent this     when (mom == guardian) $ do@@ -121,7 +125,7 @@         stepdad <- Label.insertAfter dad         rebalance mom stepdad n deltaU logU -delete :: PrimMonad m => Order (PrimState m) -> m ()+delete :: PrimMonad m => Order a (PrimState m) -> m () delete this = st $ do   when (isNil this) $ throw NullPointerException   mom <- get parent this@@ -156,25 +160,14 @@ deltaU :: Key deltaU = unsafeShiftR maxBound loglogU -- U / log U -new :: PrimMonad m => m (Order (PrimState m))-new = st $ do+new :: PrimMonad m => a -> m (Order a (PrimState m))+new a = st $ do   l <- Label.new-  makeOrder l (unsafeShiftR maxBound 1) Nil Nil+  makeOrder l (unsafeShiftR maxBound 1) a Nil Nil {-# INLINE new #-} -value :: PrimMonad m => Order (PrimState m) -> m (Key, Key)-value this = st $ do+keys :: PrimMonad m => Order a (PrimState m) -> m (Key, Key)+keys 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 #-}+{-# INLINE keys #-}
src/Data/Struct/Order.hs view
@@ -11,6 +11,7 @@ module Data.Struct.Order   ( Order   , new+  , value   , insertAfter   , delete   ) where
+ src/Data/Struct/TH.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Struct.TH (makeStruct) where++import           Control.Monad (when, zipWithM)+import           Control.Monad.Primitive (PrimMonad, PrimState)+import           Data.Either (partitionEithers)+import           Data.Primitive+import           Data.Struct+import           Data.Struct.Internal (Dict(Dict), initializeUnboxedField, st)+import           Data.List (groupBy, nub)+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax (VarStrictType)++#ifdef HLINT+{-# ANN module "HLint: ignore Use ." #-}+#endif++data StructRep = StructRep+  { srState       :: Name+  , srName        :: Name+  , srTyVars      :: [TyVarBndr]+#if MIN_VERSION_template_haskell(2,12,0)+  , srDerived     :: [DerivClause]+#else+  , srDerived     :: Cxt+#endif+  , srCxt         :: Cxt+  , srConstructor :: Name+  , srMembers     :: [Member]+  } deriving Show++data Member = Member+  { _memberRep :: Representation+  , memberName :: Name+  , _memberType :: Type+  }+  deriving Show++data Representation = BoxedField | UnboxedField | Slot+  deriving Show++-- | Generate allocators, slots, fields, unboxed fields, Eq instances,+-- and Struct instances for the given "data types".+--+-- Inputs are expected to be "data types" parameterized by a state+-- type. Strict fields are considered to be slots, Non-strict fields+-- are considered to be boxed types, Unpacked fields are considered+-- to be unboxed primitives.+--+-- The data type should use record syntax and have a single constructor.+-- The field names will be used to generate slot, field, and unboxedField+-- values of the same name.+--+-- An allocator for the struct is generated by prefixing "alloc" to the+-- data type name.+makeStruct :: DecsQ -> DecsQ+makeStruct dsq =+  do ds   <- dsq+     (passthrough, reps) <- partitionEithers <$> traverse computeRep ds+     ds's <- traverse (generateCode passthrough) reps+     return (passthrough ++ concat ds's)++mkAllocName :: StructRep -> Name+mkAllocName rep = mkName ("alloc" ++ nameBase (srName rep))++mkInitName :: StructRep -> Name+mkInitName rep = mkName ("new" ++ nameBase (srName rep))++------------------------------------------------------------------------+-- Input validation+------------------------------------------------------------------------++computeRep :: Dec -> Q (Either Dec StructRep)+computeRep (DataD c n vs _ cs ds) =+  do state <- validateStateType vs+     (conname, confields) <- validateContructor cs+     members <- traverse (validateMember state) confields++     return $ Right StructRep+       { srState = state+       , srName  = n+       , srTyVars = vs+       , srConstructor = conname+       , srMembers = members+       , srDerived = ds+       , srCxt = c+       }+computeRep d = return (Left d)++-- | Check that only a single data constructor was provided and+-- that it was a record constructor.+validateContructor :: [Con] -> Q (Name,[VarStrictType])+validateContructor [RecC name fields] = return (name,fields)+validateContructor [_] = fail "Expected a record constructor"+validateContructor xs = fail ("Expected 1 constructor, got " ++ show (length xs))++-- A struct type's final type variable should be suitable for+-- use as the ('PrimState' m) argument.+validateStateType :: [TyVarBndr] -> Q Name+validateStateType xs =+  do when (null xs) (fail "state type expected but no type variables found")+     case last xs of+       PlainTV n -> return n+       KindedTV n k+         | k == starK -> return n+         | otherwise  -> fail "state type should have kind *"+++-- | Figure out which record fields are Slots and which are+-- Fields. Slots will have types ending in the state type+validateMember :: Name -> VarStrictType -> Q Member+validateMember s (fieldname,Bang NoSourceUnpackedness NoSourceStrictness,fieldtype) =+  do when (occurs s fieldtype)+       (fail ("state type may not occur in field `" ++ nameBase fieldname ++ "`"))+     return (Member BoxedField fieldname fieldtype)+validateMember s (fieldname,Bang NoSourceUnpackedness SourceStrict,fieldtype) =+  do f <- unapplyType fieldtype s+     when (occurs s f)+       (fail ("state type may only occur in final position in slot `" ++ nameBase fieldname ++ "`"))+     return (Member Slot fieldname f)+validateMember s (fieldname,Bang SourceUnpack SourceStrict,fieldtype) =+  do when (occurs s fieldtype)+       (fail ("state type may not occur in unpacked field `" ++ nameBase fieldname ++ "`"))+     return (Member UnboxedField fieldname fieldtype)+validateMember _ _ = fail "validateMember: can't unpack nonstrict fields"++unapplyType :: Type -> Name -> Q Type+unapplyType (AppT f (VarT x)) y | x == y = return f+unapplyType _ _ = fail "Unable to match state type of slot"++------------------------------------------------------------------------+-- Code generation+------------------------------------------------------------------------++generateCode :: [Dec] -> StructRep -> DecsQ+generateCode ds rep = concat <$> sequence+  [ generateDataType rep+  , generateStructInstance rep+  , generateMembers rep+  , generateNew rep+  , generateAlloc rep+  , generateRoles ds rep+  ]++-- Generates: newtype TyCon a b c s = DataCon (Object s)+generateDataType :: StructRep -> DecsQ+generateDataType rep = sequence+  [ newtypeD (return (srCxt rep)) (srName rep) (srTyVars rep)+      Nothing+      (normalC+         (srConstructor rep)+         [ bangType+             (bang noSourceUnpackedness noSourceStrictness)+             [t| Object $(varT (srState rep)) |]+         ])+#if MIN_VERSION_template_haskell(2,12,0)+      (map return (srDerived rep))+#else+      (return (srDerived rep))+#endif+  ]++generateRoles :: [Dec] -> StructRep -> DecsQ+generateRoles ds rep+  | hasRoleAnnotation = return []+  | otherwise = sequence [ roleAnnotD (srName rep) (computeRoles rep) ]++  where+  hasRoleAnnotation = any isTargetRoleAnnot ds++  isTargetRoleAnnot (RoleAnnotD n _) = n == srName rep+  isTargetRoleAnnot _ = False++-- Currently all roles are set to nominal. A more general solution+-- should be able to infer some representional/phantom roles. To do+-- this for arbitrary types we'll need a way to query the roles of+-- existing type constructors to infer the correct roles.+computeRoles :: StructRep -> [Role]+computeRoles = map (const NominalR) . srTyVars++-- | Type of the object not applied to a state type. This+-- should have kind * -> *+repType1 :: StructRep -> TypeQ+repType1 rep = repTypeHelper (srName rep) (init (srTyVars rep))++-- | Type of the object as originally declared, fully applied.+repType :: StructRep -> TypeQ+repType rep = repTypeHelper (srName rep) (srTyVars rep)++repTypeHelper :: Name -> [TyVarBndr] -> TypeQ+repTypeHelper c vs = foldl appT (conT c) (tyVarBndrT <$> vs)++-- Construct a 'TypeQ' from a 'TyVarBndr'+tyVarBndrT :: TyVarBndr -> TypeQ+tyVarBndrT (PlainTV  n  ) = varT n+tyVarBndrT (KindedTV n k) = sigT (varT n) k++generateStructInstance :: StructRep -> DecsQ+generateStructInstance rep =+  [d| instance Struct $(repType1 rep) where struct = Dict+      instance Eq     $(repType  rep) where (==)   = eqStruct+    |]++-- generates: allocDataCon = alloc <n>+generateAlloc :: StructRep -> DecsQ+generateAlloc rep =+  do mName <- newName "m"+     let m = varT mName+         n = length (groupBy isNeighbor (srMembers rep))+         allocName = mkAllocName rep++     simpleDefinition rep allocName+       (forallT [PlainTV mName] (cxt [])+          [t| PrimMonad $m => $m ( $(repType1 rep) (PrimState $m) ) |])+       [| alloc n |]+++-- generates:+-- newDataCon a .. = do this <- alloc <n>; set field1 this a; ...; return this+generateNew :: StructRep -> DecsQ+generateNew rep =+  do this <- newName "this"+     let ms = groupBy isNeighbor (srMembers rep)++         addName m = do n <- newName (nameBase (memberName m))+                        return (n,m)++     msWithArgs <- traverse (traverse addName) ms++     let name = mkInitName rep+         body = doE+                -- allocate struct+              $ bindS (varP this) (varE (mkAllocName rep))++                -- initialize each member+              : (noBindS <$> zipWith (assignN (varE this)) [0..] msWithArgs)++                -- return initialized struct+             ++ [ noBindS [| return $(varE this) |] ]++     sequence+       [ sigD name (newStructType rep)+       , funD name [ clause (varP . fst <$> concat msWithArgs)+                            (normalB [| st $body |] ) [] ]+       ]+++assignN :: ExpQ -> Int -> [(Name,Member)] -> ExpQ++assignN this _ [(arg,Member BoxedField n _)] =+  [| setField $(varE n) $this $(varE arg) |]++assignN this _ [(arg,Member Slot n _)] =+  [| set      $(varE n) $this $(varE arg)|]++assignN this i us =+  do let n = length us+     mba <- newName "mba"+     let arg0 = fst (head us)+     doE $ bindS (varP mba) [| initializeUnboxedField i n (sizeOf $(varE arg0)) $this |]+         : [ noBindS [| writeByteArray $(varE mba) j $(varE arg) |]+           | (j,(arg,_)) <- zip [0 :: Int ..] us ]++-- | The type of the struct initializer is complicated enough to+-- pull it out here.+-- generates:+-- PrimMonad m => field1 -> field2 -> ... -> m (TyName a b ... (PrimState m))+newStructType :: StructRep -> TypeQ+newStructType rep =+  do mName <- newName "m"+     let m = varT mName+         s = [t| PrimState $m |]+         obj = repType1 rep++         buildType (Member BoxedField   _ t) = return t+         buildType (Member UnboxedField _ t) = return t+         buildType (Member Slot         _ f) = [t| $(return f) $s |]++         r = foldr (-->)+               [t| $m ($obj $s) |]+               (buildType <$> srMembers rep)++         primPreds = primPred <$> nub [ t | Member UnboxedField _ (VarT t) <- srMembers rep ]++     forallRepT rep $ forallT [PlainTV mName] (cxt primPreds)+       [t| PrimMonad $m => $r |]++-- generates a slot, field, or unboxedField definition per member+generateMembers :: StructRep -> DecsQ+generateMembers rep+  = concat <$>+    zipWithM+      (generateMember1 rep)+      [0..]+      (groupBy isNeighbor (srMembers rep))++isNeighbor :: Member -> Member -> Bool+isNeighbor (Member UnboxedField _ t) (Member UnboxedField _ u) = t == u+isNeighbor _ _ = False++------------------------------------------------------------------------++generateMember1 :: StructRep -> Int -> [Member] -> DecsQ++-- generates: fieldname = field <n>+generateMember1 rep n [Member BoxedField fieldname fieldtype] =+  simpleDefinition rep fieldname+    [t| Field $(repType1 rep) $(return fieldtype) |]+    [| field n |]++-- generates: slotname = slot <n>+generateMember1 rep n [Member Slot slotname slottype] =+  simpleDefinition rep slotname+    [t| Slot $(repType1 rep) $(return slottype) |]+    [| slot n |]++-- It the first type patterns didn't hit then we expect a list+-- of unboxed fields due to the call to groupBy in generateMembers+-- generates: fieldname = unboxedField <n> <i>+generateMember1 rep n us =+  concat <$> sequence+    [ simpleDefinition rep fieldname+          (addPrimCxt fieldtype+             [t| Field $(repType1 rep) $(return fieldtype) |])+          [| unboxedField n i |]++    | (i,Member UnboxedField fieldname fieldtype) <- zip [0 :: Int ..] us+    ]+  where+  addPrimCxt (VarT t) = forallT [] (cxt [primPred t])+  addPrimCxt _        = id++-- Generate code for definitions without arguments, with type variables+-- quantified over those in the struct rep, including an inline pragma+simpleDefinition :: StructRep -> Name -> TypeQ -> ExpQ -> DecsQ+simpleDefinition rep name typ def =+  sequence+    [ sigD name (forallRepT rep typ)+    , simpleValD name def+    , pragInlD name Inline FunLike AllPhases+    ]++------------------------------------------------------------------------++-- Simple use of 'valD' bind an expression to a name+simpleValD :: Name -> ExpQ -> DecQ+simpleValD var val = valD (varP var) (normalB val) []++-- Quantifies over all of the type variables in a struct data type+-- except the state variable which is likely to be ('PrimState' s)+forallRepT :: StructRep -> TypeQ -> TypeQ+forallRepT rep = forallT (init (srTyVars rep)) (cxt [])++(-->) :: TypeQ -> TypeQ -> TypeQ+f --> x = arrowT `appT` f `appT` x++primPred :: Name -> PredQ+primPred t = [t| Prim $(varT t) |]++occurs :: Name -> Type -> Bool+occurs n (AppT f x) = occurs n f || occurs n x+occurs n (VarT m) = n == m+occurs n (ForallT _ _ t) = occurs n t -- all names are fresh in quoted code, see below+occurs n (SigT t _) = occurs n t+occurs _ _ = False++-- Prelude Language.Haskell.TH> runQ (stringE . show =<< [t| forall a. a -> (forall a. a) |])+-- LitE (StringL "ForallT [PlainTV a_0] [] (AppT (AppT ArrowT (VarT a_0)) (ForallT [PlainTV a_1] [] (VarT a_1)))")
structs.cabal view
@@ -1,6 +1,6 @@ name:          structs category:      Data-version:       0+version:       0.1 license:       BSD3 cabal-version: >= 1.22 license-file:  LICENSE@@ -9,17 +9,25 @@ stability:     provisional homepage:      http://github.com/ekmett/structs/ bug-reports:   http://github.com/ekmett/structs/issues-copyright:     Copyright (C) 2015 Edward A. Kmett+copyright:     Copyright (C) 2015-2017 Edward A. Kmett build-type:    Custom-tested-with:   GHC == 7.10.1, GHC == 7.10.2+tested-with:   GHC == 8.0.2, GHC == 8.2.1 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+  HLint.hs   README.markdown+  Warning.hs +custom-setup+  setup-depends:+    base          >= 4.9 && <5,+    Cabal         >= 1.10,+    cabal-doctest >= 1.0.1 && <1.1+ source-repository head   type: git   location: git://github.com/ekmett/structs.git@@ -36,13 +44,15 @@  library   build-depends:-    base >= 4.8 && < 5,+    base >= 4.9 && < 5,     deepseq,+    template-haskell >= 2.11 && < 2.13,     ghc-prim,     primitive    exposed-modules:     Data.Struct+    Data.Struct.TH     Data.Struct.Internal     Data.Struct.Internal.Label     Data.Struct.Internal.LinkCut@@ -61,6 +71,8 @@   ghc-options:    -Wall -threaded   hs-source-dirs: tests   default-language: Haskell2010++  x-doctest-options: -fobject-code    if !flag(test-doctests)     buildable: False
+ tests/doctests.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- 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 (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+    traverse_ putStrLn args+    doctest args+  where+    args = flags ++ pkgs ++ module_sources
− tests/doctests.hsc 
@@ -1,78 +0,0 @@-{-# 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